Session CoSMed

iv class="head">

Theory Prelim

section â¹Preliminariesâº

theory Prelim
  imports
    "Bounded_Deducibility_Security.Compositional_Reasoning"
    "Fresh_Identifiers.Fresh_String"
begin


subsectionâ¹The basic typesâº

definition "emptyStr = STR ''''"

(* The users of the system: *)


datatype name = Nam String.literal
definition "emptyName â¡ Nam emptyStr"
datatype inform = Info String.literal
definition "emptyInfo â¡ Info emptyStr"

datatype user = Usr (nameUser : name) (infoUser : inform)
definition "emptyUser â¡ Usr emptyName emptyInfo"
fun niUser where "niUser (Usr name info) = (name,info)"


typedecl raw_data
code_printing type_constructor raw_data â (Scala) "java.io.File"

(* Images (currently, pdf, to be changed): *)
datatype img  = emptyImg | Imag raw_data
(* Visibility outside the current api: either friends-only or public  *)
datatype vis = Vsb String.literal
(* Accepted values: friend and public  *)
abbreviation "FriendV â¡ Vsb (STR ''friend'')"
abbreviation "PublicV â¡ Vsb (STR ''public'')"
fun stringOfVis where "stringOfVis (Vsb str) = str"

(* A post consists of a string for title, a string for its text,
  a (possibly empty) image and a visibility specification: *)

datatype title = Tit String.literal
definition "emptyTitle â¡ Tit emptyStr"
datatype "text" = Txt String.literal
definition "emptyText â¡ Txt emptyStr"

datatype post = Ntc (titlePost : title) (textPost : "text") (imgPost : img)
(* Setters: *)
fun setTitlePost where "setTitlePost (Ntc title text img) title' = Ntc title' text img"
fun setTextPost where "setTextPost(Ntc title text img) text' = Ntc title text' img"
fun setImgPost where "setImgPost (Ntc title text img) img' = Ntc title text img'"
(*  *)
definition emptyPost :: post where
"emptyPost â¡ Ntc emptyTitle emptyText emptyImg"
(* initially set to the lowest visibility: friend *)

lemma set_get_post[simp]:
"titlePost (setTitlePost ntc title) = title"
"titlePost (setTextPost ntc text) = titlePost ntc"
"titlePost (setImgPost ntc img) = titlePost ntc"
(* *)
"textPost (setTitlePost ntc title) = textPost ntc"
"textPost (setTextPost ntc text) = text"
"textPost (setImgPost ntc img) = textPost ntc"
(* *)
"imgPost (setTitlePost ntc title) = imgPost ntc"
"imgPost (setTextPost ntc text) = imgPost ntc"
"imgPost (setImgPost ntc img) = img"
by(cases ntc, auto)+

datatype password = Psw String.literal
definition "emptyPass â¡ Psw emptyStr"

(* Information associated to requests for registration: both for users and apps *)
datatype req = ReqInfo String.literal
definition "emptyReq â¡ ReqInfo emptyStr"


subsection â¹Identifiersâº

datatype userID = Uid String.literal
datatype postID = Nid String.literal

definition "emptyUserID â¡ Uid emptyStr"
definition "emptyPostID â¡ Nid emptyStr"


(*  *)
fun userIDAsStr where "userIDAsStr (Uid str) = str"

definition "getFreshUserID userIDs â¡ Uid (fresh (set (map userIDAsStr userIDs)) (STR ''2''))"

lemma UserID_userIDAsStr[simp]: "Uid (userIDAsStr userID) = userID"
by (cases userID) auto

lemma member_userIDAsStr_iff[simp]: "str â userIDAsStr ` (set userIDs) â· Uid str ââ userIDs"
by (metis UserID_userIDAsStr image_iff userIDAsStr.simps)

lemma getFreshUserID: "Â¬ getFreshUserID userIDs ââ userIDs"
using fresh_notIn[of "set (map userIDAsStr userIDs)"] unfolding getFreshUserID_def by auto

(*  *)
fun postIDAsStr where "postIDAsStr (Nid str) = str"

definition "getFreshPostID postIDs â¡ Nid (fresh (set (map postIDAsStr postIDs)) (STR ''3''))"

lemma PostID_postIDAsStr[simp]: "Nid (postIDAsStr postID) = postID"
by (cases postID) auto

lemma member_postIDAsStr_iff[simp]: "str â postIDAsStr ` (set postIDs) â· Nid str ââ postIDs"
by (metis PostID_postIDAsStr image_iff postIDAsStr.simps)

lemma getFreshPostID: "Â¬ getFreshPostID postIDs ââ postIDs"
using fresh_notIn[of "set (map postIDAsStr postIDs)"] unfolding getFreshPostID_def by auto

end

Theory System_Specification

section â¹System specificationâº

theory System_Specification
imports Prelim
begin

(* This is the system specification of COSMED.
*)

declare List.insert[simp]

subsection â¹The stateâº

record state =
  admin :: userID
  (*  *)
  pendingUReqs :: "userID list"
  userReq :: "userID â req"
  userIDs :: "userID list"
  user :: "userID â user"
  pass :: "userID â password"
  (*  *)
  pendingFReqs :: "userID â userID list"
  friendReq :: "userID â userID â req"
  friendIDs :: "userID â userID list"
  (*  *)
  postIDs :: "postID list"
  post :: "postID â post"
  owner :: "postID â userID"
  vis :: "postID â vis"

definition IDsOK :: "state â userID list â postID list â bool"
where
"IDsOK s uIDs pIDs â¡
 list_all (Î» uID. uID ââ userIDs s) uIDs â§
 list_all (Î» pID. pID ââ postIDs s) pIDs"


subsection â¹The actionsâº

subsubsectionâ¹Initialization of the systemâº

definition istate :: state
where
"istate â¡
 â¦
  admin = emptyUserID,

  pendingUReqs = [],
  userReq = (Î» uID. emptyReq),
  userIDs = [],
  user = (Î» uID. emptyUser),
  pass = (Î» uID. emptyPass),

  pendingFReqs = (Î» uID. []),
  friendReq = (Î» uID uID'. emptyReq),
  friendIDs = (Î» uID. []),

  postIDs = [],
  post = (Î» papID. emptyPost),
  owner = (Î» pID. emptyUserID),
  vis = (Î» pID. FriendV)
 â¦"


subsubsectionâ¹Starting actionâº

(* This initiates the system. It has the following parameters:
  -- uID, p, name: the admin user id, name and password
*)
definition startSys ::
"state â userID â password â state"
where
"startSys s uID p â¡
 s â¦admin := uID,
    userIDs := [uID],
    user := (user s) (uID := emptyUser),
    pass := (pass s) (uID := p)â¦"

definition e_startSys :: "state â userID â password â  bool"
where
"e_startSys s uID p â¡ userIDs s = []"


subsubsectionâ¹Creation actionsâº


(* Create new user request: we allow users to choose their own IDs; they could be their email addresses. *)
definition createNUReq :: "state â userID â req â state"
where
"createNUReq s uID reqInfo â¡
 s â¦pendingUReqs := pendingUReqs s @ [uID],
    userReq := (userReq s)(uID := reqInfo)
â¦"

definition e_createNUReq :: "state â userID â req â bool"
where
"e_createNUReq s uID req â¡
 admin s ââ userIDs s â§ Â¬ uID ââ userIDs s â§ Â¬ uID ââ pendingUReqs s"
(* a new-user request can be created only if the system has started, i.e., if an admin exists *)

(* The admin actually creates a user by approving a pending new-user request.
E.g., the admin can add an  arbitrary password and send it by email to that user.
Then the user can change his password. *)
definition createUser :: "state â userID â password â userID â password â state"
where
"createUser s uID p uID' p' â¡
 s â¦userIDs := uID' # (userIDs s),
    user := (user s) (uID' := emptyUser),
    pass := (pass s) (uID' := p'),
    pendingUReqs := remove1 uID' (pendingUReqs s),
    userReq := (userReq s)(uID := emptyReq)â¦"

definition e_createUser :: "state â userID â password â userID â password â bool"
where
"e_createUser s uID p uID' p' â¡
 IDsOK s [uID] [] â§ pass s uID = p â§ uID = admin s â§ uID' ââ pendingUReqs s"


(* Create post: note that post ID is an action parameter, and that the enabledness action
checks that it is fresh.
The web interface will actually generate it, using getFresh. *)
definition createPost :: "state â userID â password â postID â title â state"
where
"createPost s uID p pID title â¡
 s â¦postIDs := pID # postIDs s,
    post := (post s) (pID := Ntc title emptyText emptyImg),
    owner := (owner s) (pID := uID)â¦"
(* Recall from the initial state that the initial visibility is FriendV *)

definition e_createPost :: "state â userID â password â postID â title â bool"
where
"e_createPost s uID p pID title â¡
 IDsOK s [uID] [] â§ pass s uID = p â§
 Â¬ pID ââ postIDs s"

(* Friendship: *)
(* Create friend request, namely uID Reqs friendship of uID': *)
definition createFriendReq :: "state â userID â password â userID â req â state"
where
"createFriendReq s uID p uID' req â¡
 let pfr = pendingFReqs s in
 s â¦pendingFReqs := pfr (uID' := pfr uID' @ [uID]),
    friendReq := fun_upd2 (friendReq s) uID uID' reqâ¦"

definition e_createFriendReq :: "state â userID â password â userID â req â bool"
where
"e_createFriendReq s uID p uID' req â¡
 IDsOK s [uID,uID'] [] â§ pass s uID = p â§
 Â¬ uID ââ pendingFReqs s uID' â§ Â¬ uID ââ friendIDs s uID'"

(* Create friend, by approving a friend request (namely uID approves the request from uID').
Friendship is symmetric, hence the two updates to "friend";
also, the friendship request is canceled upon approval.  *)
definition createFriend :: "state â userID â password â userID â state"
where
"createFriend s uID p uID' â¡
 let fr = friendIDs s; pfr = pendingFReqs s in
 s â¦friendIDs := fr (uID := fr uID @ [uID'], uID' := fr uID' @ [uID]),
    pendingFReqs := pfr (uID := remove1 uID' (pfr uID), uID' := remove1 uID (pfr uID')),
    friendReq := fun_upd2 (fun_upd2 (friendReq s) uID' uID emptyReq) uID uID' emptyReqâ¦"

definition e_createFriend :: "state â userID â password â userID â bool"
where
"e_createFriend s uID p uID' â¡
 IDsOK s [uID,uID'] [] â§ pass s uID = p â§
 uID' ââ pendingFReqs s uID"


subsubsectionâ¹Updating actionsâº

(* Users can update their passwords and names: *)
definition updateUser :: "state â userID â password â password â name â inform â state"
where
"updateUser s uID p p' name info â¡
 s â¦user := (user s) (uID := Usr name info),
    pass := (pass s) (uID := p')â¦"

definition e_updateUser :: "state â userID â password â password â name â inform â bool"
where
"e_updateUser s uID p p' name info â¡
 IDsOK s [uID] [] â§ pass s uID = p"


(* Updates of the post components: *)
definition updatePost :: "state â userID â password â postID â post â state"
where
"updatePost s uID p pID pst â¡
 s â¦post := (post s) (pID := pst)â¦"

definition e_updatePost :: "state â userID â password â postID â post â bool"
where
"e_updatePost s uID p pID pst â¡
 IDsOK s [uID] [pID] â§ pass s uID = p â§
 owner s pID = uID"

definition updateVisPost :: "state â userID â password â postID â vis â state"
where
"updateVisPost s uID p pID vs â¡
 s â¦vis := (vis s) (pID := vs)â¦"

definition e_updateVisPost :: "state â userID â password â postID â vis â bool"
where
"e_updateVisPost s uID p pID vs â¡
 IDsOK s [uID] [pID] â§ pass s uID = p â§
 owner s pID = uID â§ vs â {FriendV, PublicV}"



subsubsectionâ¹Deletion (removal) actionsâº

(* Delete friend:   *)
definition deleteFriend :: "state â userID â password â userID â state"
where
"deleteFriend s uID p uID' â¡
 let fr = friendIDs s in
 s â¦friendIDs := fr (uID := removeAll uID' (fr uID), uID' := removeAll uID (fr uID'))â¦"

definition e_deleteFriend :: "state â userID â password â userID â bool"
where
"e_deleteFriend s uID p uID' â¡
 IDsOK s [uID,uID'] [] â§ pass s uID = p â§
 uID' ââ friendIDs s uID"


subsubsectionâ¹Reading actionsâº

(* Read new user request: *)
definition readNUReq :: "state â userID â password â userID â req"
where
"readNUReq s uID p uID' â¡ userReq s uID'"

definition e_readNUReq :: "state â userID â password â userID â bool"
where
"e_readNUReq s uID p uID' â¡
 IDsOK s [uID] [] â§ pass s uID = p â§
 uID = admin s â§ uID' ââ pendingUReqs s"

(* A user can read their name and info (and so can all the other users), but not the password: *)
definition readUser :: "state â userID â password â userID â name Ã inform"
where
"readUser s uID p uID' â¡ niUser (user s uID')"

definition e_readUser :: "state â userID â password â userID â bool"
where
"e_readUser s uID p uID' â¡
 IDsOK s [uID,uID'] [] â§ pass s uID = p"

(* A user can check if he is the admin: *)
definition readAmIAdmin :: "state â userID â password â bool"
where
"readAmIAdmin s uID p â¡ uID = admin s"

definition e_readAmIAdmin :: "state â userID â password â bool"
where
"e_readAmIAdmin s uID p â¡
 IDsOK s [uID] [] â§ pass s uID = p"

(* Reading posts: *)
definition readPost :: "state â userID â password â postID â post"
where
"readPost s uID p pID â¡ post s pID"

definition e_readPost :: "state â userID â password â postID â bool"
where
"e_readPost s uID p pID â¡
 let post = post s pID in
 IDsOK s [uID] [pID] â§ pass s uID = p â§
 (owner s pID = uID â¨ uID ââ friendIDs s (owner s pID) â¨ vis s pID = PublicV)"

definition readVisPost :: "state â userID â password â postID â vis"
where
"readVisPost s uID p pID â¡ vis s pID"

definition e_readVisPost :: "state â userID â password â postID â bool"
where
"e_readVisPost s uID p pID â¡
 let post = post s pID in
 IDsOK s [uID] [pID] â§ pass s uID = p â§
 (owner s pID = uID â¨ uID ââ friendIDs s (owner s pID) â¨ vis s pID = PublicV)"

definition readOwnerPost :: "state â userID â password â postID â userID"
where
"readOwnerPost s uID p pID â¡ owner s pID"

definition e_readOwnerPost :: "state â userID â password â postID â bool"
where
"e_readOwnerPost s uID p pID â¡
 let post = post s pID in
 IDsOK s [uID] [pID] â§ pass s uID = p â§
 (owner s pID = uID â¨ uID ââ friendIDs s (owner s pID) â¨ vis s pID = PublicV)"


(* Friendship: *)
(* Read friendship request to me: *)
definition readFriendReqToMe :: "state â userID â password â userID â req"
where
"readFriendReqToMe s uID p uID' â¡ friendReq s uID' uID"

definition e_readFriendReqToMe :: "state â userID â password â userID â bool"
where
"e_readFriendReqToMe s uID p uID' â¡
 IDsOK s [uID,uID'] [] â§ pass s uID = p â§
 uID' ââ pendingFReqs s uID"

(* Read friendship request from me: *)
definition readFriendReqFromMe :: "state â userID â password â userID â req"
where
"readFriendReqFromMe s uID p uID' â¡ friendReq s uID uID'"

definition e_readFriendReqFromMe :: "state â userID â password â userID â bool"
where
"e_readFriendReqFromMe s uID p uID' â¡
 IDsOK s [uID,uID'] [] â§ pass s uID = p â§
 uID ââ pendingFReqs s uID'"


subsubsectionâ¹Listing actionsâº

(* list pending new user requests: *)
definition listPendingUReqs :: "state â userID â password â userID list"
where
"listPendingUReqs s uID p â¡ pendingUReqs s"

definition e_listPendingUReqs :: "state â userID â password â bool"
where
"e_listPendingUReqs s uID p â¡
 IDsOK s [uID] [] â§ pass s uID = p â§ uID = admin s"

(* list all users of the system: *)
definition listAllUsers :: "state â userID â password â userID list"
where
"listAllUsers s uID p â¡ userIDs s"

definition e_listAllUsers :: "state â userID â password â bool"
where
"e_listAllUsers s uID p â¡ IDsOK s [uID] [] â§ pass s uID = p"


(* List a user's friends: *)
definition listFriends :: "state â userID â password â userID â userID list"
where
"listFriends s uID p uID' â¡ friendIDs s uID'"

definition e_listFriends :: "state â userID â password â userID â bool"
where
"e_listFriends s uID p uID' â¡
 IDsOK s [uID,uID'] [] â§ pass s uID = p â§
 (uID = uID' â¨ uID ââ friendIDs s uID')"

(* list posts:: *)
definition listPosts :: "state â userID â password â (userID Ã postID) list"
where
"listPosts s uID p â¡
  [(owner s pID, pID).
    pID â postIDs s,
    vis s pID = PublicV â¨ uID ââ friendIDs s (owner s pID) â¨ uID = owner s pID
  ]"

definition e_listPosts :: "state â userID â password â bool"
where
"e_listPosts s uID p â¡ IDsOK s [uID] [] â§ pass s uID = p"



subsectionâ¹The step functionâº

datatype out =
  (* Outputs for creation and update actions, as well as for other actions with errors: *)
  outOK | outErr |
  (* Outputs for reading actions: *)
  outBool bool| outNI "name Ã inform" | outPost post |
  outImg img | outVis vis | outReq req |
  (* Outputs for listing actions: *)
  outUID "userID" | outUIDL "userID list" |
  outUIDNIDL "(userID Ã postID)list"
  (* outNone (* Used later for global actions *) *)


(* Start actions (only one, but wrapped for uniformity): *)
datatype sActt =
  sSys userID password

lemmas s_defs =
e_startSys_def startSys_def

fun sStep :: "state â sActt â out * state" where
"sStep s (sSys uID p) =
 (if e_startSys s uID p
    then (outOK, startSys s uID p)
    else (outErr, s))"

fun sUserOfA :: "sActt â userID" where
 "sUserOfA (sSys uID p) = uID"

(* Creation actions: *)
datatype cActt =
  cNUReq userID req
 |cUser userID password userID password
 |cFriendReq userID password userID req
 |cFriend userID password userID
 |cPost userID password postID title

lemmas c_defs =
e_createNUReq_def createNUReq_def
e_createUser_def createUser_def
e_createFriendReq_def createFriendReq_def
e_createFriend_def createFriend_def
e_createPost_def createPost_def

fun cStep :: "state â cActt â out * state" where
"cStep s (cNUReq uID req) =
 (if e_createNUReq s uID req
    then (outOK, createNUReq s uID req)
    else (outErr, s))"
|
"cStep s (cUser uID p uID' p') =
 (if e_createUser s uID p uID' p'
    then (outOK, createUser s uID p uID' p')
    else (outErr, s))"
|
"cStep s (cFriendReq uID p uID' req) =
 (if e_createFriendReq s uID p uID' req
    then (outOK, createFriendReq s uID p uID' req)
    else (outErr, s))"
|
"cStep s (cFriend uID p uID') =
 (if e_createFriend s uID p uID'
    then (outOK, createFriend s uID p uID')
    else (outErr, s))"
|
"cStep s (cPost uID p pID title) =
 (if e_createPost s uID p pID title
    then (outOK, createPost s uID p pID title)
    else (outErr, s))"

fun cUserOfA :: "cActt â userID option" where
 "cUserOfA (cNUReq uID req) = Some uID"
|"cUserOfA (cUser uID p uID' p') = Some uID"
|"cUserOfA (cFriendReq uID p uID' req) = Some uID"
|"cUserOfA (cFriend uID p uID') = Some uID"
|"cUserOfA (cPost uID p pID title) = Some uID"



(* Deletion (removal) actions -- currently only friends can be deleted *)

datatype dActt =
  dFriend userID password userID

lemmas d_defs =
e_deleteFriend_def deleteFriend_def

fun dStep :: "state â dActt â out * state" where
"dStep s (dFriend uID p uID') =
 (if e_deleteFriend s uID p uID'
    then (outOK, deleteFriend s uID p uID')
    else (outErr, s))"

fun dUserOfA :: "dActt â userID" where
 "dUserOfA (dFriend uID p uID') = uID"

(* Update actions: *)
datatype uActt =
  uUser userID password password name inform
 |uPost userID password postID post
 |uVisPost userID password postID vis

lemmas u_defs =
e_updateUser_def updateUser_def
e_updatePost_def updatePost_def
e_updateVisPost_def updateVisPost_def

fun uStep :: "state â uActt â out * state" where
"uStep s (uUser uID p p' name info) =
 (if e_updateUser s uID p p' name info
    then (outOK, updateUser s uID p p' name info)
    else (outErr, s))"
|
"uStep s (uPost uID p pID pst) =
 (if e_updatePost s uID p pID pst
    then (outOK, updatePost s uID p pID pst)
    else (outErr, s))"
|
"uStep s (uVisPost uID p pID visStr) =
 (if e_updateVisPost s uID p pID visStr
    then (outOK, updateVisPost s uID p pID visStr)
    else (outErr, s))"

fun uUserOfA :: "uActt â userID" where
 "uUserOfA (uUser uID p p' name info) = uID"
|"uUserOfA (uPost uID p pID pst) = uID"
|"uUserOfA (uVisPost uID p pID visStr) = uID"


(* Read actions: *)
datatype rActt =
  rNUReq userID password userID
 |rUser userID password userID
 |rAmIAdmin userID password
 |rPost userID password postID
 |rVisPost userID password postID
 |rOwnerPost userID password postID
 |rFriendReqToMe userID password userID
 |rFriendReqFromMe userID password userID

lemmas r_defs =
 readNUReq_def e_readNUReq_def
 readUser_def e_readUser_def
 readAmIAdmin_def e_readAmIAdmin_def
 readPost_def e_readPost_def
 readVisPost_def e_readVisPost_def
 readOwnerPost_def e_readOwnerPost_def
 readFriendReqToMe_def e_readFriendReqToMe_def
 readFriendReqFromMe_def e_readFriendReqFromMe_def

fun rObs :: "state â rActt â out" where
"rObs s (rNUReq uID p uID') =
 (if e_readNUReq s uID p uID' then outReq (readNUReq s uID p uID') else outErr)"
|
"rObs s (rUser uID p uID') =
 (if e_readUser s uID p uID' then outNI (readUser s uID p uID') else outErr)"
|
"rObs s (rAmIAdmin uID p) =
 (if e_readAmIAdmin s uID p then outBool (readAmIAdmin s uID p) else outErr)"
|
"rObs s (rPost uID p pID) =
 (if e_readPost s uID p pID then outPost (readPost s uID p pID) else outErr)"
|
"rObs s (rVisPost uID p pID) =
 (if e_readVisPost s uID p pID then outVis (readVisPost s uID p pID) else outErr)"
|
"rObs s (rOwnerPost uID p pID) =
 (if e_readOwnerPost s uID p pID then outUID (readOwnerPost s uID p pID) else outErr)"
|
"rObs s (rFriendReqToMe uID p uID') =
 (if e_readFriendReqToMe s uID p uID' then outReq (readFriendReqToMe s uID p uID') else outErr)"
|
"rObs s (rFriendReqFromMe uID p uID') =
 (if e_readFriendReqFromMe s uID p uID' then outReq (readFriendReqFromMe s uID p uID') else outErr)"


fun rUserOfA :: "rActt â userID option" where
 "rUserOfA (rNUReq uID p uID') = Some uID"
|"rUserOfA (rUser uID p uID') = Some uID"
|"rUserOfA (rAmIAdmin uID p) = Some uID"
|"rUserOfA (rPost uID p pID) = Some uID"
|"rUserOfA (rVisPost uID p pID) = Some uID"
|"rUserOfA (rOwnerPost uID p pID) = Some uID"
|"rUserOfA (rFriendReqToMe uID p uID') = Some uID"
|"rUserOfA (rFriendReqFromMe uID p uID') = Some uID"


(* Listing actions *)
datatype lActt =
  lPendingUReqs userID password
 |lAllUsers userID password
 |lFriends userID password userID
 |lPosts userID password


lemmas l_defs =
 listPendingUReqs_def e_listPendingUReqs_def
 listAllUsers_def e_listAllUsers_def
 listFriends_def e_listFriends_def
 listPosts_def e_listPosts_def


fun lObs :: "state â lActt â out" where
"lObs s (lPendingUReqs uID p) =
 (if e_listPendingUReqs s uID p then outUIDL (listPendingUReqs s uID p) else outErr)"
|
"lObs s (lAllUsers uID p) =
 (if e_listAllUsers s uID p then outUIDL (listAllUsers s uID p) else outErr)"
|
"lObs s (lFriends uID p uID') =
 (if e_listFriends s uID p uID' then outUIDL (listFriends s uID p uID') else outErr)"
|
"lObs s (lPosts uID p) =
 (if e_listPosts s uID p then outUIDNIDL (listPosts s uID p) else outErr)"


fun lUserOfA :: "lActt â userID option" where
 "lUserOfA (lPendingUReqs uID p) = Some uID"
|"lUserOfA (lAllUsers uID p) = Some uID"
|"lUserOfA (lFriends uID p uID') = Some uID"
|"lUserOfA (lPosts uID p) = Some uID"



(* All actions: *)
datatype act =
  Sact sActt |
(* 3 kinds of effects: creation, deletion and update *)
  Cact cActt | Dact dActt | Uact uActt |
(* 2 kinds of observations: reading and listing (the latter mainly printing IDs) *)
  Ract rActt | Lact lActt


fun step :: "state â act â out * state" where
"step s (Sact sa) = sStep s sa"
|
"step s (Cact ca) = cStep s ca"
|
"step s (Dact da) = dStep s da"
|
"step s (Uact ua) = uStep s ua"
|
"step s (Ract ra) = (rObs s ra, s)"
|
"step s (Lact la) = (lObs s la, s)"

fun userOfA :: "act â userID option" where
"userOfA (Sact sa) = Some (sUserOfA sa)"
|
"userOfA (Cact ca) = cUserOfA ca"
|
"userOfA (Dact da) = Some (dUserOfA da)"
|
"userOfA (Uact ua) = Some (uUserOfA ua)"
|
"userOfA (Ract ra) = rUserOfA ra"
|
"userOfA (Lact la) = lUserOfA la"



subsection â¹Code generationâº

export_code step istate getFreshPostID in Scala


end

Theory Automation_Setup

theory Automation_Setup
imports System_Specification
begin

lemma add_prop:
  assumes "PROP (T)"
  shows "A ==> PROP (T)"
  using assms .


lemmas exhaust_elim =
   sActt.exhaust[of x, THEN add_prop[where A="a=Sact x"], rotated -1]
   cActt.exhaust[of x, THEN add_prop[where A="a=Cact x"], rotated -1]
   uActt.exhaust[of x, THEN add_prop[where A="a=Uact x"], rotated -1]
   rActt.exhaust[of x, THEN add_prop[where A="a=Ract x"], rotated -1]
   lActt.exhaust[of x, THEN add_prop[where A="a=Lact x"], rotated -1]
  for x a


lemma state_cong:
fixes s::state
assumes
"pendingUReqs s = pendingUReqs s1 â§ userReq s = userReq s1 â§ userIDs s = userIDs s1 â§
 postIDs s = postIDs s1 â§ admin s = admin s1 â§
 user s = user s1 â§ pass s = pass s1 â§ pendingFReqs s = pendingFReqs s1 â§ friendReq s = friendReq s1 â§ friendIDs s = friendIDs s1 â§
 post s = post s1 â§
 owner s = owner s1 â§
 vis s = vis s1"
shows "s = s1"
using assms by (cases s, cases s1) auto


end

Theory Safety_Properties

section â¹Safety propertiesâº

theory Safety_Properties
imports Automation_Setup "Bounded_Deducibility_Security.Compositional_Reasoning"
begin

interpretation IO_Automaton where
istate = istate and step = step
done

declare if_splits[split]
declare IDsOK_def[simp]

lemmas eff_defs = s_defs c_defs d_defs u_defs
lemmas obs_defs = r_defs l_defs
lemmas all_defs = eff_defs obs_defs
lemmas step_elims = step.elims sStep.elims cStep.elims dStep.elims uStep.elims

declare sstep_Cons[simp]

lemma Lact_Ract_noStateChange[simp]:
assumes "a â Lact ` UNIV âª Ract ` UNIV"
shows "snd (step s a) = s"
using assms by (cases a) auto

lemma Lact_Ract_noStateChange_set:
assumes "set al â Lact ` UNIV âª Ract ` UNIV"
shows "snd (sstep s al) = s"
using assms by (induct al) (auto split: prod.splits)

lemma reach_postIDs_persist:
  "pID ââ postIDs s â¹ step s a = (ou,s') â¹ pID ââ postIDs s'"
  by (cases a) (auto elim: step_elims simp: eff_defs)

lemma reach_visPost: "reach s â¹ vis s pID â {FriendV, PublicV}"
proof (induction rule: reach_step_induct)
  case (Step s a)
  then show ?case proof (cases a)
    case (Sact sAct)
    with Step show ?thesis
      by (cases sAct) (auto simp add: s_defs)
  next
    case (Cact cAct)
    with Step show ?thesis
      by (cases cAct) (auto simp add: c_defs)
  next
    case (Dact dAct)
    with Step show ?thesis
      by (cases dAct) (auto simp add: d_defs)
  next
    case (Uact uAct)
    with Step show ?thesis
      by (cases uAct) (auto simp add: u_defs)
  qed auto
qed (auto simp add: istate_def)

lemma reach_owner_userIDs: "reach s â¹ pID ââ postIDs s â¹ owner s pID ââ userIDs s"
proof (induction rule: reach_step_induct)
  case (Step s a)
  then show ?case proof (cases a)
    case (Sact sAct)
    with Step show ?thesis
      by (cases sAct) (auto simp add: s_defs)
  next
    case (Cact cAct)
    with Step show ?thesis
      by (cases cAct) (auto simp add: c_defs)
  next
    case (Dact dAct)
    with Step show ?thesis
      by (cases dAct) (auto simp add: d_defs)
  next
    case (Uact uAct)
    with Step show ?thesis
      by (cases uAct) (auto simp add: u_defs)
  qed auto
qed (auto simp add: istate_def)

lemma reach_friendIDs_symmetric:
"reach s â¹ uID1 ââ friendIDs s uID2 â· uID2 ââ friendIDs s uID1"
proof (induction rule: reach_step_induct)
  case (Step s a) then show ?case proof (cases a)
    case (Sact sAct) with Step show ?thesis by (cases sAct) (auto simp add: s_defs) next
    case (Cact cAct) with Step show ?thesis by (cases cAct) (auto simp add: c_defs ) next
    case (Dact dAct) with Step show ?thesis by (cases dAct) (auto simp add: d_defs ) next
    case (Uact uAct) with Step show ?thesis by (cases uAct) (auto simp add: u_defs)
  qed auto
qed (auto simp add: istate_def)

lemma reach_not_postIDs_vis_FriendV:
assumes  "reach s" "Â¬ pid ââ postIDs s"
shows "vis s pid = FriendV"
using assms proof (induction rule: reach_step_induct)
  case (Step s a) then show ?case proof (cases a)
    case (Sact sAct) with Step show ?thesis by (cases sAct) (auto simp add: s_defs) next
    case (Cact cAct) with Step show ?thesis by (cases cAct) (auto simp add: c_defs ) next
    case (Dact dAct) with Step show ?thesis by (cases dAct) (auto simp add: d_defs ) next
    case (Uact uAct) with Step show ?thesis by (cases uAct) (auto simp add: u_defs)
  qed auto
qed (auto simp add: istate_def)

lemma reach_distinct_friends_reqs:
assumes "reach s"
shows "distinct (friendIDs s uid)" and "distinct (pendingFReqs s uid)"
  and "uid' ââ pendingFReqs s uid â¹ uid' â set (friendIDs s uid)"
  and "uid' ââ pendingFReqs s uid â¹ uid â set (friendIDs s uid')"
using assms proof (induction arbitrary: uid uid' rule: reach_step_induct)
  case Istate
    fix uid uid'
    show "distinct (friendIDs istate uid)" and "distinct (pendingFReqs istate uid)"
     and "uid' ââ pendingFReqs istate uid â¹ uid' â set (friendIDs istate uid)"
     and "uid' ââ pendingFReqs istate uid â¹ uid â set (friendIDs istate uid')"
      unfolding istate_def by auto
next
  case (Step s a)
    have s': "reach (snd (step s a))" using reach_step[OF Step(1)] .
    { fix uid uid'
      have "distinct (friendIDs (snd (step s a)) uid) â§ distinct (pendingFReqs (snd (step s a)) uid)
          â§ (uid' ââ pendingFReqs (snd (step s a)) uid â¶ uid' â set (friendIDs (snd (step s a)) uid))"
      proof (cases a)
        case (Sact sa) with Step show ?thesis by (cases sa) (auto simp add: s_defs) next
        case (Cact ca) with Step show ?thesis by (cases ca) (auto simp add: c_defs) next
        case (Dact da) with Step show ?thesis by (cases da) (auto simp add: d_defs distinct_removeAll) next
        case (Uact ua) with Step show ?thesis by (cases ua) (auto simp add: u_defs) next
        case (Ract ra) with Step show ?thesis by auto next
        case (Lact ra) with Step show ?thesis by auto
      qed
    } note goal = this
    fix uid uid'
    from goal show "distinct (friendIDs (snd (step s a)) uid)"
               and "distinct (pendingFReqs (snd (step s a)) uid)" by auto
    assume "uid' ââ pendingFReqs (snd (step s a)) uid"
    with goal show "uid' â set (friendIDs (snd (step s a)) uid)" by auto
    then show "uid â set (friendIDs (snd (step s a)) uid')"
      using reach_friendIDs_symmetric[OF s'] by simp
qed

lemma remove1_in_set: "x ââ remove1 y xs â¹ x ââ xs"
by (induction xs) auto

lemma reach_IDs_used_IDsOK[rule_format]:
assumes "reach s"
shows "uid ââ pendingFReqs s uid' â¶ IDsOK s [uid, uid'] []" (is ?p)
and "uid ââ friendIDs s uid' â¶ IDsOK s [uid, uid'] []" (is ?f)
using assms proof -
  from assms have "uid ââ pendingFReqs s uid' â¨ uid ââ friendIDs s uid'
               â¶ IDsOK s [uid, uid'] []"
  proof (induction rule: reach_step_induct)
    case Istate then show ?case by (auto simp add: istate_def)
  next
    case (Step s a) then show ?case proof (cases a)
      case (Sact sa) with Step show ?thesis by (cases sa) (auto simp: s_defs) next
      case (Cact ca) with Step show ?thesis by (cases ca) (auto simp: c_defs intro: remove1_in_set) next
      case (Dact da) with Step show ?thesis by (cases da) (auto simp: d_defs) next
      case (Uact ua) with Step show ?thesis by (cases ua) (auto simp: u_defs)
    qed auto
  qed
  then show ?p and ?f by auto
qed

lemma IDs_mono[rule_format]:
assumes "step s a = (ou, s')"
shows "uid ââ userIDs s â¶ uid ââ userIDs s'" (is "?u")
and "pid ââ postIDs s â¶ pid ââ postIDs s'" (is "?n")
proof -
  from assms have "?u â§ ?n" proof (cases a)
    case (Sact sa) with assms show ?thesis by (cases sa) (auto simp add: s_defs) next
    case (Cact ca) with assms show ?thesis by (cases ca) (auto simp add: c_defs) next
    case (Dact da) with assms show ?thesis by (cases da) (auto simp add: d_defs) next
    case (Uact ua) with assms show ?thesis by (cases ua) (auto simp add: u_defs)
  qed (auto)
  then show "?u" "?n" by auto
qed

lemma IDsOK_mono:
assumes "step s a = (ou, s')"
and "IDsOK s uIDs pIDs"
shows "IDsOK s' uIDs pIDs"
using IDs_mono[OF assms(1)] assms(2)
  by (auto simp add: list_all_iff)






end

Theory Observation_Setup

(* The observation functions, the same for all our confidentiality properties *)
theory Observation_Setup
imports Safety_Properties
begin

sectionâ¹The observation setupâº

text â¹The observers are a arbitrary but fixed set of users:âº

consts UIDs :: "userID set"

type_synonym obs = "act * out"

text â¹The observations are all their actions:âº

fun Î³ :: "(state,act,out) trans â bool" where
"Î³ (Trans _ a _ _) =
 (userOfA a â Some ` UIDs)"

fun g :: "(state,act,out)trans â obs" where
"g (Trans _ a ou _) = (a,ou)"


end

Theory Post_Intro

theory Post_Intro
  imports "../Safety_Properties" "../Observation_Setup"
begin

section â¹Post confidentialityâº

text â¹We prove the following property:

\ \\
Given a group of users â¹UIDsâº and a post â¹PIDâº,

that group cannot learn anything about the different versions of the post â¹PIDâº
(the initial created version and the later ones obtained by updating the post)

beyond the updates performed while or last before one of the following holds:
\begin{itemize}
\item either a user in â¹UIDsâº is the post's owner, a friend of the owner, or the admin
\item or â¹UIDsâº has at least one registered user and the post is marked as ``public''.
\end{itemize}
âº


end

Theory Post_Value_Setup

(* The value setup for post confidentiality *)
theory Post_Value_Setup
imports Post_Intro
begin

text â¹The ID of the confidential post:âº

consts PID :: postID

subsectionâ¹Preliminariesâº

(*
(* two posts equal everywhere but w.r.t. their content: *)
fun eqButT :: "post â post â bool" where
"eqButT ntc ntc1 =
 (titlePost ntc = titlePost ntc1 â§
  imgPost ntc = imgPost ntc1 â§
  visPost ntc = visPost ntc1)"

lemma eqButT_eq[simp,intro!]: "eqButT pap pap"
by(cases pap) auto

lemma eqButT_sym:
assumes "eqButT pap pap1"
shows "eqButT pap1 pap"
apply(cases pap, cases pap1)
using assms by auto

lemma eqButT_trans:
assumes "eqButT pap pap1" and "eqButT pap1 pap2"
shows "eqButT pap pap2"
apply(cases pap, cases pap1, cases pap2)
using assms by auto
*)

(* Auxiliary notion: two functions are equal everywhere but on PID *)
definition eeqButPID where
"eeqButPID ntcs ntcs1 â¡
 â pid. pid â  PID â¶  ntcs pid = ntcs1 pid"

(* â pid. if pid = PID then eqButT (ntcs PID) (ntcs1 PID) else ntcs pid = ntcs1 pid *)

lemmas eeqButPID_intro = eeqButPID_def[THEN meta_eq_to_obj_eq, THEN iffD2]

lemma eeqButPID_eeq[simp,intro!]: "eeqButPID ntcs ntcs"
unfolding eeqButPID_def by auto

lemma eeqButPID_sym:
assumes "eeqButPID ntcs ntcs1" shows "eeqButPID ntcs1 ntcs"
using assms unfolding eeqButPID_def by auto

lemma eeqButPID_trans:
assumes "eeqButPID ntcs ntcs1" and "eeqButPID ntcs1 ntcs2" shows "eeqButPID ntcs ntcs2"
using assms unfolding eeqButPID_def by (auto split: if_splits)

lemma eeqButPID_cong:
assumes "eeqButPID ntcs ntcs1"
and "PID = PID â¹ eqButT uu uu1"
and "pid â  PID â¹ uu = uu1"
shows "eeqButPID (ntcs (pid := uu)) (ntcs1(pid := uu1))"
using assms unfolding eeqButPID_def by (auto split: if_splits)

(* lemma eeqButPID_eqButT:
"eeqButPID ntcs ntcs1 â¹ eqButT (ntcs PID) (ntcs1 PID)"
unfolding eeqButPID_def by (auto split: if_splits)
*)

lemma eeqButPID_not_PID:
"â¦eeqButPID ntcs ntcs1; pid â  PIDâ§ â¹ ntcs pid = ntcs1 pid"
unfolding eeqButPID_def by (auto split: if_splits)

(*
lemma eeqButPID_postSelectors:
"eeqButPID ntcs ntcs1 â¹
 visPost (ntcs pid) = visPost (ntcs1 pid)"
  unfolding eeqButPID_def sledgehammer  by (metis eqButT.simps)
*)

lemma eeqButPID_toEq:
assumes "eeqButPID ntcs ntcs1"
shows "ntcs (PID := pst) = ntcs1 (PID := pst)"
using eeqButPID_not_PID[OF assms] by auto

lemma eeqButPID_update_post:
assumes "eeqButPID ntcs ntcs1"
shows "eeqButPID (ntcs (pid := ntc)) (ntcs1 (pid := ntc))"
using eeqButPID_not_PID[OF assms]
using assms unfolding eeqButPID_def by auto

(* The notion of two states being equal everywhere but on the content of
   the post associated to a given PID: *)
definition eqButPID :: "state â state â bool" where
"eqButPID s s1 â¡
 admin s = admin s1 â§

 pendingUReqs s = pendingUReqs s1 â§ userReq s = userReq s1 â§
 userIDs s = userIDs s1 â§ user s = user s1 â§ pass s = pass s1 â§

 pendingFReqs s = pendingFReqs s1 â§ friendReq s = friendReq s1 â§ friendIDs s = friendIDs s1 â§

 postIDs s = postIDs s1 â§ admin s = admin s1 â§
 eeqButPID (post s) (post s1) â§
 owner s = owner s1 â§
 vis s = vis s1"

lemmas eqButPID_intro = eqButPID_def[THEN meta_eq_to_obj_eq, THEN iffD2]

lemma eqButPID_refl[simp,intro!]: "eqButPID s s"
unfolding eqButPID_def by auto

lemma eqButPID_sym:
assumes "eqButPID s s1" shows "eqButPID s1 s"
using assms eeqButPID_sym unfolding eqButPID_def by auto

lemma eqButPID_trans:
assumes "eqButPID s s1" and "eqButPID s1 s2" shows "eqButPID s s2"
using assms eeqButPID_trans unfolding eqButPID_def
by simp blast

(* Implications from eqButPID, including w.r.t. auxiliary operations: *)
lemma eqButPID_stateSelectors:
"eqButPID s s1 â¹
 admin s = admin s1 â§

 pendingUReqs s = pendingUReqs s1 â§ userReq s = userReq s1 â§
 userIDs s = userIDs s1 â§ user s = user s1 â§ pass s = pass s1 â§

 pendingFReqs s = pendingFReqs s1 â§ friendReq s = friendReq s1 â§ friendIDs s = friendIDs s1 â§

 postIDs s = postIDs s1 â§ admin s = admin s1 â§
 eeqButPID (post s) (post s1) â§
 owner s = owner s1 â§
 vis s = vis s1 â§

 IDsOK s = IDsOK s1"
unfolding eqButPID_def IDsOK_def[abs_def] by auto

(* lemma eqButPID_eqButT:
"eqButPID s s1 â¹ eqButT (post s PID) (post s1 PID)"
unfolding eqButPID_def using eeqButPID_eqButT by auto *)

lemma eqButPID_not_PID:
"eqButPID s s1 â¹ pid â  PID â¹ post s pid = post s1 pid"
unfolding eqButPID_def using eeqButPID_not_PID by auto

lemma eqButPID_actions:
assumes "eqButPID s s1"
shows "listPosts s uid p = listPosts s1 uid p"
using eqButPID_stateSelectors[OF assms]
by (auto simp: l_defs intro!: arg_cong2[of _ _ _ _ cmap])

lemma eqButPID_setPost:
assumes "eqButPID s s1"
shows "(post s)(PID := pst) = (post s1)(PID := pst)"
using assms unfolding eqButPID_def using eeqButPID_toEq by auto

lemma eqButPID_update_post:
assumes "eqButPID s s1"
shows "eeqButPID ((post s) (pid := ntc)) ((post s1) (pid := ntc))"
using assms unfolding eqButPID_def using eeqButPID_update_post by auto

lemma eqButPID_cong[simp, intro]:
"â uu1 uu2. eqButPID s s1 â¹ uu1 = uu2 â¹ eqButPID (s â¦admin := uu1â¦) (s1 â¦admin := uu2â¦)"

"â uu1 uu2. eqButPID s s1 â¹ uu1 = uu2 â¹ eqButPID (s â¦pendingUReqs := uu1â¦) (s1 â¦pendingUReqs := uu2â¦)"
"â uu1 uu2. eqButPID s s1 â¹ uu1 = uu2 â¹ eqButPID (s â¦userReq := uu1â¦) (s1 â¦userReq := uu2â¦)"
"â uu1 uu2. eqButPID s s1 â¹ uu1 = uu2 â¹ eqButPID (s â¦userIDs := uu1â¦) (s1 â¦userIDs := uu2â¦)"
"â uu1 uu2. eqButPID s s1 â¹ uu1 = uu2 â¹ eqButPID (s â¦user := uu1â¦) (s1 â¦user := uu2â¦)"
"â uu1 uu2. eqButPID s s1 â¹ uu1 = uu2 â¹ eqButPID (s â¦pass := uu1â¦) (s1 â¦pass := uu2â¦)"

"â uu1 uu2. eqButPID s s1 â¹ uu1 = uu2 â¹ eqButPID (s â¦postIDs := uu1â¦) (s1 â¦postIDs := uu2â¦)"
"â uu1 uu2. eqButPID s s1 â¹ uu1 = uu2 â¹ eqButPID (s â¦owner := uu1â¦) (s1 â¦owner := uu2â¦)"
"â uu1 uu2. eqButPID s s1 â¹ eeqButPID uu1 uu2 â¹ eqButPID (s â¦post := uu1â¦) (s1 â¦post := uu2â¦)"
"â uu1 uu2. eqButPID s s1 â¹ uu1 = uu2 â¹ eqButPID (s â¦vis := uu1â¦) (s1 â¦vis := uu2â¦)"

"â uu1 uu2. eqButPID s s1 â¹ uu1 = uu2 â¹ eqButPID (s â¦pendingFReqs := uu1â¦) (s1 â¦pendingFReqs := uu2â¦)"
"â uu1 uu2. eqButPID s s1 â¹ uu1 = uu2 â¹ eqButPID (s â¦friendReq := uu1â¦) (s1 â¦friendReq := uu2â¦)"
"â uu1 uu2. eqButPID s s1 â¹ uu1 = uu2 â¹ eqButPID (s â¦friendIDs := uu1â¦) (s1 â¦friendIDs := uu2â¦)"

unfolding eqButPID_def by auto


subsectionâ¹Value Setupâº

datatype "value" =
  TVal post â â¹updated content of the confidential postâº
| OVal bool â â¹updated dynamic declassification trigger conditionâº

text â¹Openness of the access window to the confidential information in a given state,
i.e.~the dynamic declassification trigger condition:âº

definition openToUIDs where
"openToUIDs s â¡
 â uid â UIDs.
   uid ââ userIDs s â§
   (uid = owner s PID â¨ uid ââ friendIDs s (owner s PID) â¨
    vis s PID = PublicV)"


definition "open" where "open s â¡ PID ââ postIDs s â§ openToUIDs s"

lemmas open_defs = openToUIDs_def open_def

lemma eqButPID_openToUIDs:
assumes "eqButPID s s1"
shows "openToUIDs s â· openToUIDs s1"
using eqButPID_stateSelectors[OF assms]
unfolding openToUIDs_def by auto

lemma eqButPID_open:
assumes "eqButPID s s1"
shows "open s â· open s1"
using assms eqButPID_openToUIDs eqButPID_stateSelectors
unfolding open_def by auto

lemma not_open_eqButPID:
assumes 1: "Â¬ open s" and 2: "eqButPID s s1"
shows "Â¬ open s1"
using 1 unfolding eqButPID_open[OF 2] .

fun Ï :: "(state,act,out) trans â bool" where
"Ï (Trans _ (Uact (uPost uid p pid pst)) ou _) = (pid = PID â§ ou = outOK)"
|
"Ï (Trans s _ _ s') = (open s â  open s')"

lemma Ï_def2:
  assumes "step s a = (ou,s')"
  shows
    "Ï (Trans s a ou s') â·
     (âuid p pst. a = Uact (uPost uid p PID pst) â§ ou = outOK) â¨
      open s â  open s'"
proof (cases a)
  case (Uact ua)
  then show ?thesis
    using assms
    by (cases ua, auto simp: u_defs open_defs)
qed auto

fun f :: "(state,act,out) trans â value" where
"f (Trans s (Uact (uPost uid p pid pst)) _ s') =
 (if pid = PID then TVal pst else OVal (open s'))"
|
"f (Trans s _ _ s') = OVal (open s')"

lemma Uact_uPost_step_eqButPID:
assumes a: "a = Uact (uPost uid p PID pst)"
and "step s a = (ou,s')"
shows "eqButPID s s'"
using assms unfolding eqButPID_def eeqButPID_def
by (auto simp: u_defs split: if_splits)


(* Key lemma: *)
lemma eqButPID_step:
assumes ss1: "eqButPID s s1"
and step: "step s a = (ou,s')"
and step1: "step s1 a = (ou1,s1')"
shows "eqButPID s' s1'"
proof -
  note [simp] = all_defs
                eeqButPID_def
  note [intro!] = eqButPID_intro
  note * =
    step step1 ss1
    eqButPID_stateSelectors[OF ss1]
    eqButPID_setPost[OF ss1] eqButPID_update_post[OF ss1]
  then show ?thesis
  proof (cases a)
    case (Sact x1)
    then show ?thesis using * by (cases x1) auto
  next
    case (Cact x2)
    then show ?thesis using * by (cases x2) auto
  next
    case (Dact x3)
    then show ?thesis using * by (cases x3) auto
  next
    case (Uact x4)
    show ?thesis
    proof (cases x4)
      case (uUser x11 x12 x13 x14 x15)
      then show ?thesis using Uact * by auto
    next
      case (uPost x31 x32 x33 x34)
      then show ?thesis using Uact * by (cases "x33 = PID") auto
    next
      case (uVisPost x51 x52 x53 x54)
      then show ?thesis using Uact * by (cases "x53 = PID") auto
    qed
  qed auto
qed

lemma eqButPID_step_Ï_imp:
assumes ss1: "eqButPID s s1"
and step: "step s a = (ou,s')" and step1: "step s1 a = (ou1,s1')"
and Ï: "Ï (Trans s a ou s')"
shows "Ï (Trans s1 a ou1 s1')"
proof-
  have s's1': "eqButPID s' s1'"
  using eqButPID_step local.step ss1 step1 by blast
  show ?thesis using step step1 Ï eqButPID_open[OF ss1] eqButPID_open[OF s's1']
  using eqButPID_stateSelectors[OF ss1]
  unfolding Ï_def2[OF step] Ï_def2[OF step1]
  by (auto simp: u_defs)
qed

(* Key lemma: *)
lemma eqButPID_step_Ï:
assumes s's1': "eqButPID s s1"
and step: "step s a = (ou,s')" and step1: "step s1 a = (ou1,s1')"
shows "Ï (Trans s a ou s') = Ï (Trans s1 a ou1 s1')"
by (metis eqButPID_step_Ï_imp eqButPID_sym assms)


end

class="head">

Theory Post

theory Post
imports "../Observation_Setup" Post_Value_Setup
begin

subsection â¹Declassification boundâº


fun T :: "(state,act,out) trans â bool" where "T _ = False"

text â¹\label{sec:post-bound}
The bound may dynamically change from closed (â¹Bâº) to open (â¹BOâº) access to the
confidential information (or vice versa) when the openness predicate changes value.
The bound essentially relates arbitrary value sequences in the closed phase (i.e.~observers
learn nothing about the updates during that phase) and identical value sequences in the open phase
(i.e.~observers may learn everything about the updates during that phase);
when transitioning from a closed to an open access window (â¹B_BOâº below),
the last update in the closed phase, i.e.~the current version of the post,
is also declassified in addition to subsequent updates.
This formalizes the ``while-or-last-before'' scheme in the informal description of the
confidentiality property.
Moreover, the empty value sequence is treated specially in order to capture harmless cases
where the observers may deduce that no secret updates have occurred,
e.g.~if the system has not been initialized yet.
See @{cite â¹Section 3.4âº "cosmed-jar2018"} for a detailed discussion of the bound.âº

inductive B :: "value list â value list â bool"
and BO :: "value list â value list â bool"
where
 B_TVal[simp,intro!]:
  "(pstl = [] â¶ pstl1 = []) â¹ B (map TVal pstl) (map TVal pstl1)"
|B_BO[intro]:
  "BO vl vl1 â¹ (pstl = [] â· pstl1 = []) â¹ (pstl â  [] â¹ last pstl = last pstl1) â¹
   B (map TVal pstl  @ OVal True # vl)
     (map TVal pstl1 @ OVal True # vl1)"
(*  *)
|BO_TVal[simp,intro!]:
  "BO (map TVal pstl) (map TVal pstl)"
|BO_B[intro]:
  "B vl vl1 â¹
   BO (map TVal pstl @ OVal False # vl) (map TVal pstl @ OVal False # vl1)"

lemma B_not_Nil: "B vl vl1 â¹ vl = [] â¹ vl1 = []"
by(auto elim: B.cases)

lemma B_OVal_True:
assumes "B (OVal True # vl') vl1"
shows "â vl1'. BO vl' vl1' â§ vl1 = OVal True # vl1'"
using assms apply(auto elim!: B.cases)
by (metis append_self_conv2 hd_append list.map_disc_iff list.map_sel(1) list.sel(1)
       list.sel(3) value.distinct(1))+

no_notation relcomp (infixr "O" 75)

interpretation BD_Security_IO where
istate = istate and step = step and
Ï = Ï and f = f and Î³ = Î³ and g = g and T = T and B = B
done


subsection â¹Unwinding proofâº

(* Key lemma: *)
lemma eqButPID_step_Î³_out:
assumes ss1: "eqButPID s s1"
and step: "step s a = (ou,s')" and step1: "step s1 a = (ou1,s1')"
and op: "Â¬ open s"
and sT: "reachNT s" and s1: "reach s1"
and Î³: "Î³ (Trans s a ou s')"
shows "ou = ou1"
proof-
  note [simp] = all_defs
                open_defs
  note s = reachNT_reach[OF sT]
  note willUse =
  step step1 Î³
  not_open_eqButPID[OF op ss1]
  reach_visPost[OF s]
  eqButPID_stateSelectors[OF ss1]
  eqButPID_actions[OF ss1]
  eqButPID_not_PID[OF ss1]
  {fix uid p pid assume "a = Ract (rPost uid p pid)"
   hence ?thesis using willUse
   by (cases "pid = PID") fastforce+
  } note intCase1 = this
  show ?thesis
  proof (cases a)
    case (Sact x1)
    then show ?thesis using intCase1 willUse by (cases x1) auto
  next
    case (Cact x2)
    then show ?thesis using intCase1 willUse by (cases x2) auto
  next
    case (Dact x3)
    then show ?thesis using intCase1 willUse by (cases x3) auto
  next
    case (Uact x4)
    then show ?thesis using intCase1 willUse by (cases x4) auto
  next
    case (Ract x5)
    then show ?thesis using intCase1 willUse by (cases x5) auto
  next
    case (Lact x6)
    then show ?thesis using intCase1 willUse by (cases x6) auto
  qed
qed

(* Key lemma: *)
lemma eqButPID_step_eq:
assumes ss1: "eqButPID s s1"
and a: "a = Uact (uPost uid p PID pst)" "ou = outOK"
and step: "step s a = (ou, s')" and step1: "step s1 a = (ou', s1')"
shows "s' = s1'"
using ss1 step step1
using eqButPID_stateSelectors[OF ss1] eqButPID_setPost[OF ss1]
unfolding a by (auto simp: u_defs)

definition Î0 :: "state â value list â state â value list â bool" where
"Î0 s vl s1 vl1 â¡
 Â¬ PID ââ postIDs s â§
 s = s1 â§ B vl vl1"

definition Î1 :: "state â value list â state â value list â bool" where
"Î1 s vl s1 vl1 â¡
 PID ââ postIDs s â§
 (â pstl pstl1. (pstl = [] â¶ pstl1 = []) â§ vl = map TVal pstl â§ vl1 = map TVal pstl1) â§
 eqButPID s s1 â§ Â¬ open s"

definition Î2 :: "state â value list â state â value list â bool" where
"Î2 s vl s1 vl1 â¡
 PID ââ postIDs s â§
 (â pstl. vl = map TVal pstl â§ vl1 = map TVal pstl) â§
 s = s1 â§ open s"

definition Î31 :: "state â value list â state â value list â bool" where
"Î31 s vl s1 vl1 â¡
 PID ââ postIDs s â§
 (â pstl pstl1 vll vll1.
    BO vll vll1 â§ pstl â  [] â§ pstl1 â  [] â§ last pstl = last pstl1 â§
    vl = map TVal pstl @ OVal True # vll â§ vl1 = map TVal pstl1 @ OVal True # vll1) â§
 eqButPID s s1 â§ Â¬ open s"

definition Î32 :: "state â value list â state â value list â bool" where
"Î32 s vl s1 vl1 â¡
 PID ââ postIDs s â§
 (â vll vll1.
    BO vll vll1 â§
    vl = OVal True # vll â§ vl1 = OVal True # vll1) â§
 s = s1 â§ Â¬ open s"

definition Î4 :: "state â value list â state â value list â bool" where
"Î4 s vl s1 vl1 â¡
 PID ââ postIDs s â§
 (â pstl vll vll1.
    B vll vll1 â§
    vl = map TVal pstl @ OVal False # vll â§ vl1 = map TVal pstl @ OVal False # vll1) â§
 s = s1 â§ open s"

lemma istate_Î0:
assumes B: "B vl vl1"
shows "Î0 istate vl istate vl1"
using assms unfolding Î0_def istate_def by auto

lemma unwind_cont_Î0: "unwind_cont Î0 {Î0,Î1,Î2,Î31,Î32,Î4}"
proof(rule, simp)
  let ?Î = "Î»s vl s1 vl1. Î0 s vl s1 vl1 â¨
                           Î1 s vl s1 vl1 â¨ Î2 s vl s1 vl1 â¨
                           Î31 s vl s1 vl1 â¨ Î32 s vl s1 vl1 â¨ Î4 s vl s1 vl1"
  fix s s1 :: state and vl vl1 :: "value list"
  assume rsT: "reachNT s" and rs1: "reach s1" and "Î0 s vl s1 vl1"
  hence rs: "reach s" and ss1: "s1 = s" and B: "B vl vl1" and PID: "Â¬ PID ââ postIDs s"
  using reachNT_reach unfolding Î0_def by auto
  have vlvl1: "vl = [] â¹ vl1 = []" using B_not_Nil B by auto
  have op: "Â¬ open s" using PID unfolding open_defs by auto
  show "iaction ?Î s vl s1 vl1 â¨
        ((vl = [] â¶ vl1 = []) â§ reaction ?Î s vl s1 vl1)" (is "?iact â¨ (_ â§ ?react)")
  proof-
    have ?react proof
      fix a :: act and ou :: out and s' :: state and vl'
      let ?trn = "Trans s a ou s'"  let ?trn1 = "Trans s1 a ou s'"
      assume step: "step s a = (ou, s')" and T: "Â¬ T ?trn" and c: "consume ?trn vl vl'"
      show "match ?Î s s1 vl1 a ou s' vl' â¨ ignore ?Î s s1 vl1 a ou s' vl'" (is "?match â¨ ?ignore")
      proof-
        have ?match proof(cases "â uid p text. a = Cact (cPost uid p PID text) â§ ou = outOK")
          case True
          then obtain uid p "text" where a: "a = Cact (cPost uid p PID text)" and ou: "ou = outOK" by auto
          have PID': "PID ââ postIDs s'"
          using step PID unfolding a ou by (auto simp: c_defs)
          show ?thesis proof(cases "uid â UIDs â¨ (â uid' â UIDs. uid' ââ userIDs s â§ (uid' ââ friendIDs s uid))")
            case True note uid = True
            have op': "open s'" using uid using step PID' unfolding a ou by (auto simp: c_defs open_defs)
            have Ï: "Ï ?trn" using op op' unfolding Ï_def2[OF step] by simp
            then obtain v where vl: "vl = v # vl'" and f: "f ?trn = v"
            using c unfolding consume_def Ï_def2 by(cases vl) auto
            have v: "v = OVal True" using f op op' unfolding a by simp
            then obtain vl1' where BO': "BO vl' vl1'" and vl1: "vl1 = OVal True # vl1'"
            using B_OVal_True B unfolding vl v by auto
            show ?thesis proof
              show "validTrans ?trn1" unfolding ss1 using step by simp
            next
              show "consume ?trn1 vl1 vl1'" using Ï f unfolding vl1 v consume_def ss1 by simp
            next
              show "Î³ ?trn = Î³ ?trn1" unfolding ss1 by simp
            next
              assume "Î³ ?trn" thus "g ?trn = g ?trn1" unfolding ss1 by simp
            next
              show "?Î s' vl' s' vl1'" using BO' proof(cases rule: BO.cases)
                case (BO_TVal pstl)
                hence "Î2 s' vl' s' vl1'" using PID' op' unfolding Î2_def by auto
                thus ?thesis by simp
              next
                case (BO_B vll vll1 pstl)
                hence "Î4 s' vl' s' vl1'" using PID' op' unfolding Î4_def by auto
                thus ?thesis by simp
              qed
            qed
          next
            case False note uid = False
            have op': "Â¬ open s'" using step op uid unfolding open_defs a
              by (auto simp add: c_defs reach_not_postIDs_vis_FriendV rs)
            have Ï: "Â¬ Ï ?trn" using op op' a unfolding Ï_def2[OF step] by auto
            hence vl': "vl' = vl" using c unfolding consume_def by simp
            show ?thesis proof
              show "validTrans ?trn1" unfolding ss1 using step by simp
            next
              show "consume ?trn1 vl1 vl1" using Ï unfolding consume_def ss1 by auto
            next
              show "Î³ ?trn = Î³ ?trn1" unfolding ss1 by simp
            next
              assume "Î³ ?trn" thus "g ?trn = g ?trn1" unfolding ss1 by simp
            next
              show "?Î s' vl' s' vl1" using B proof(cases rule: B.cases)
                case (B_TVal pstl)
                hence "Î1 s' vl' s' vl1" using PID' op' unfolding Î1_def vl' by auto
                thus ?thesis by simp
              next
                case (B_BO vll vll1 pstl pstl1)
                show ?thesis
                proof(cases "pstl â  [] â§ pstl1 â  []")
                  case True
                  hence "Î31 s' vl' s' vl1" using B_BO PID' op' unfolding Î31_def vl' by auto
                  thus ?thesis by simp
                next
                  case False
                  hence "Î32 s' vl' s' vl1" using B_BO PID' op' unfolding Î32_def vl' by auto
                  thus ?thesis by simp
                qed
              qed
            qed
          qed
        next
          case False note a = False
          have op': "Â¬ open s'"
            using a step PID op unfolding open_defs
            by (cases a) (auto elim: step_elims simp: all_defs)
          have Ï: "Â¬ Ï ?trn" using PID step op op' unfolding Ï_def2[OF step] by (auto simp: u_defs)
          hence vl': "vl' = vl" using c unfolding consume_def by simp
          have PID': "Â¬ PID ââ postIDs s'"
            using step PID a
            by (cases a) (auto elim: step_elims simp: all_defs)
          show ?thesis proof
            show "validTrans ?trn1" unfolding ss1 using step by simp
          next
            show "consume ?trn1 vl1 vl1" using Ï unfolding consume_def ss1 by auto
          next
            show "Î³ ?trn = Î³ ?trn1" unfolding ss1 by simp
          next
            assume "Î³ ?trn" thus "g ?trn = g ?trn1" unfolding ss1 by simp
          next
            have "Î0 s' vl' s' vl1" using a B PID' unfolding Î0_def vl' by simp
            thus "?Î s' vl' s' vl1" by simp
          qed
        qed
        thus ?thesis by simp
      qed
    qed
  thus ?thesis using vlvl1 by simp
  qed
qed

lemma unwind_cont_Î1: "unwind_cont Î1 {Î1}"
proof(rule, simp)
  let ?Î = "Î»s vl s1 vl1. Î1 s vl s1 vl1"
  fix s s1 :: state and vl vl1 :: "value list"
  assume rsT: "reachNT s" and rs1: "reach s1" and "Î1 s vl s1 vl1"
  then obtain pstl pstl1 where
  t: "pstl = [] â¶ pstl1 = []"
  and vl: "vl = map TVal pstl" and vl1: "vl1 = map TVal pstl1"
  and rs: "reach s" and ss1: "eqButPID s s1" and op: "Â¬ open s" and PID: "PID ââ postIDs s"
  using reachNT_reach unfolding Î1_def by auto
  have vlvl1: "vl = [] â¹ vl1 = []" using t unfolding vl vl1 by auto
  have PID1: "PID ââ postIDs s1" using eqButPID_stateSelectors[OF ss1] PID by auto
  have own: "owner s PID â set (userIDs s)" using reach_owner_userIDs[OF rs PID] .
  hence own1: "owner s1 PID â set (userIDs s1)" using eqButPID_stateSelectors[OF ss1] by auto
  have op1: "Â¬ open s1" using op ss1 eqButPID_open by auto
  show "iaction ?Î s vl s1 vl1 â¨
        ((vl = [] â¶ vl1 = []) â§ reaction ?Î s vl s1 vl1)" (is "?iact â¨ (_ â§ ?react)")
  proof(cases pstl1)
    case (Cons text1 pstll1) note pstl1 = Cons
    define uid where uid: "uid â¡ owner s PID"  define p where p: "p â¡ pass s uid"
    define a1 where a1: "a1 â¡ Uact (uPost uid p PID text1)"
    have uid1: "uid = owner s1 PID" and p1: "p = pass s1 uid" unfolding uid p
    using eqButPID_stateSelectors[OF ss1] by auto
    obtain ou1 s1' where step1: "step s1 a1 = (ou1, s1')" by(cases "step s1 a1") auto
    have ou1: "ou1 = outOK" using step1 PID1 own1 unfolding a1 uid1 p1 by (auto simp: u_defs)
    have op1': "Â¬ open s1'" using step1 op1 unfolding a1 ou1 open_defs by (auto simp: u_defs)
    have uid: "uid â UIDs" unfolding uid using op PID own unfolding open_defs by auto
    let ?trn1 = "Trans s1 a1 ou1 s1'"
    have ?iact proof
      show "step s1 a1 = (ou1, s1')" using step1 .
    next
      show Ï: "Ï ?trn1" unfolding Ï_def2[OF step1] a1 ou1 by simp
      show "consume ?trn1 vl1 (map TVal pstll1)"
      using Ï unfolding vl1 consume_def pstl1 a1 by auto
    next
      show "Â¬ Î³ ?trn1" using uid unfolding a1 by auto
    next
      have "eqButPID s1 s1'" using Uact_uPost_step_eqButPID[OF _ step1] a1 by auto
      hence ss1': "eqButPID s s1'" using eqButPID_trans ss1 by blast
      show "?Î s vl s1' (map TVal pstll1)" using PID op t ss1' unfolding Î1_def vl pstl1 by auto
    qed
    thus ?thesis by simp
  next
    case Nil note pstl1 = Nil
    have ?react proof
      fix a :: act and ou :: out and s' :: state and vl'
      let ?trn = "Trans s a ou s'"
      assume step: "step s a = (ou, s')" and T: "Â¬ T ?trn" and c: "consume ?trn vl vl'"
      have PID': "PID ââ postIDs s'" using reach_postIDs_persist[OF PID step] .
      obtain ou1 s1' where step1: "step s1 a = (ou1, s1')" by(cases "step s1 a") auto
      let ?trn1 = "Trans s1 a ou1 s1'"
      show "match ?Î s s1 vl1 a ou s' vl' â¨ ignore ?Î s s1 vl1 a ou s' vl'" (is "?match â¨ ?ignore")
      proof(cases "â uid p textt. a = Uact (uPost uid p PID textt) â§ ou = outOK")
        case True then obtain uid p textt where
        a: "a = Uact (uPost uid p PID textt)" and ou: "ou = outOK" by auto
        hence Ï: "Ï ?trn" unfolding Ï_def2[OF step] by auto
        then obtain "text" pstl' where pstl: "pstl = text # pstl'" and f: "f ?trn = TVal text"
        and vl': "vl' = map TVal pstl'"
        using c unfolding consume_def Ï_def2 vl by (cases pstl) auto
        have textt: "textt = text" using f unfolding a by auto
        have uid: "uid â UIDs" using step op PID unfolding a ou open_defs by (auto simp: u_defs)
        have "eqButPID s s'" using Uact_uPost_step_eqButPID[OF a step] by auto
        hence s's1: "eqButPID s' s1" using eqButPID_sym eqButPID_trans ss1 by blast
        have op': "Â¬ open s'" using step PID' op unfolding a ou open_defs by (auto simp: u_defs)
        have ?ignore proof
          show "Â¬ Î³ ?trn" unfolding a using uid by auto
        next
          show "?Î s' vl' s1 vl1" using PID' s's1 op' unfolding Î1_def vl' vl1 pstl1 by auto
        qed
        thus ?thesis by simp
      next
        case False note a = False
        {assume Ï: "Ï ?trn"
         then obtain "text" pstl' where pstl: "pstl = text # pstl'" and f: "f ?trn = TVal text"
         and vl': "vl' = map TVal pstl'" using c unfolding consume_def vl by (cases pstl) auto
         have False using f a Ï by (cases ?trn rule: Ï.cases) auto
        }
        hence Ï: "Â¬ Ï ?trn" by auto
        have op': "Â¬ open s'" using a op Ï unfolding Ï_def2[OF step] by auto
        have vl': "vl' = vl" using c Ï unfolding consume_def by auto
        have s's1': "eqButPID s' s1'" using eqButPID_step[OF ss1 step step1] .
        have op1': "Â¬ open s1'" using op' eqButPID_open[OF s's1'] by simp
        have "â uid p text. e_updatePost s1 uid p PID text â· e_updatePost s uid p PID text"
        using eqButPID_stateSelectors[OF ss1] unfolding u_defs by auto
        hence ou1: "â uid p text. a = Uact (uPost uid p PID text) â¹ ou1 = ou"
        using step step1 by auto
        hence Ï1: "Â¬ Ï ?trn1" using a op1 op1' unfolding Ï_def2[OF step1] by auto
        have ?match proof
          show "validTrans ?trn1" using step1 by simp
        next
          show "consume ?trn1 vl1 vl1" using Ï1 unfolding consume_def by simp
        next
          show "Î³ ?trn = Î³ ?trn1" unfolding ss1 by simp
        next
          assume "Î³ ?trn"
          hence "ou1 = ou" using eqButPID_step_Î³_out[OF ss1 step step1 op rsT rs1] by simp
          thus "g ?trn = g ?trn1" by simp
        next
          show "?Î s' vl' s1' vl1" using s's1' op' PID' unfolding Î1_def vl' vl vl1 pstl1 by auto
        qed
      thus ?thesis by simp
      qed
    qed
    thus ?thesis using vlvl1 by simp
  qed
qed

lemma unwind_cont_Î2: "unwind_cont Î2 {Î2}"
proof(rule, simp)
  let ?Î = "Î»s vl s1 vl1. Î2 s vl s1 vl1"
  fix s s1 :: state and vl vl1 :: "value list"
  assume rsT: "reachNT s" and rs1: "reach s1" and "Î2 s vl s1 vl1"
  then obtain pstl where
  vl: "vl = map TVal pstl" and vl1: "vl1 = map TVal pstl"
  and rs: "reach s" and ss1: "s1 = s" and op: "open s" and PID: "PID ââ postIDs s"
  using reachNT_reach unfolding Î2_def by fastforce
  have vlvl1: "vl = [] â¹ vl1 = []" unfolding vl vl1 by auto
  have own: "owner s PID â set (userIDs s)" using reach_owner_userIDs[OF rs PID] .
  show "iaction ?Î s vl s1 vl1 â¨
        ((vl = [] â¶ vl1 = []) â§ reaction ?Î s vl s1 vl1)" (is "?iact â¨ (_ â§ ?react)")
  proof-
    have ?react proof
      fix a :: act and ou :: out and s' :: state and vl'
      let ?trn = "Trans s a ou s'"  let ?trn1 = "Trans s1 a ou s'"
      assume step: "step s a = (ou, s')" and T: "Â¬ T ?trn" and c: "consume ?trn vl vl'"
      have PID': "PID ââ postIDs s'" using reach_postIDs_persist[OF PID step] .
      {assume op': "Â¬ open s'"
       hence Ï: "Ï ?trn" using op unfolding Ï_def2[OF step] by simp
       then obtain "text" pstl' where pstl: "pstl = text # pstl'" and f: "f ?trn = TVal text" and vl': "vl' = map TVal pstl'"
       using c unfolding consume_def Ï_def2 vl by(cases pstl) auto
       obtain uid p where a: "a = Uact (uPost uid p PID text)" and ou: "ou = outOK"
         using f Ï by (cases ?trn rule: Ï.cases) auto
       have False using step op op' PID PID' unfolding a ou open_defs by (auto simp: u_defs)
      }
      hence op': "open s'" by auto
      show "match ?Î s s1 vl1 a ou s' vl' â¨ ignore ?Î s s1 vl1 a ou s' vl'" (is "?match â¨ ?ignore")
      proof-
        have ?match proof(cases "Ï ?trn")
          case True note Ï = True
          then obtain "text" pstl' where pstl: "pstl = text # pstl'" and f: "f ?trn = TVal text" and vl': "vl' = map TVal pstl'"
          using c unfolding consume_def Ï_def2 vl by(cases pstl) auto
          obtain uid p textt where a: "a = Uact (uPost uid p PID textt)" and ou: "ou = outOK"
          using Ï op op' unfolding Ï_def2[OF step] by auto
          have textt: "textt = text" using f unfolding a by simp
          show ?thesis proof
            show "validTrans ?trn1" unfolding ss1 using step by simp
          next
            show "consume ?trn1 vl1 vl'" using Ï unfolding ss1 consume_def vl1 vl vl' pstl f by auto
          next
            show "Î³ ?trn = Î³ ?trn1" unfolding ss1 by simp
          next
            assume "Î³ ?trn" thus "g ?trn = g ?trn1" unfolding ss1 by simp
          next
            show "?Î s' vl' s' vl'" using PID' op' unfolding Î2_def vl1 vl' vl by auto
          qed
        next
          case False note Ï = False
          hence vl': "vl' = vl" using c unfolding consume_def by auto
          show ?thesis proof
            show "validTrans ?trn1" unfolding ss1 using step by simp
          next
            show "consume ?trn1 vl1 vl" using Ï unfolding ss1 consume_def vl1 vl vl' by auto
          next
            show "Î³ ?trn = Î³ ?trn1" unfolding ss1 by simp
          next
            assume "Î³ ?trn" thus "g ?trn = g ?trn1" unfolding ss1 by simp
          next
            show "?Î s' vl' s' vl" using PID' op' unfolding Î2_def vl1 vl' vl by auto
          qed
        qed
      thus ?thesis by simp
      qed
    qed
  thus ?thesis using vlvl1 by simp
  qed
qed

lemma unwind_cont_Î31: "unwind_cont Î31 {Î31,Î32}"
proof(rule, simp)
  let ?Î = "Î»s vl s1 vl1. Î31 s vl s1 vl1 â¨ Î32 s vl s1 vl1"
  fix s s1 :: state and vl vl1 :: "value list"
  assume rsT: "reachNT s" and rs1: "reach s1" and "Î31 s vl s1 vl1"
  then obtain pstl pstl1 vll vll1 where BO: "BO vll vll1" and
  t: "pstl â  []" "pstl1 â  []" "last pstl = last pstl1"
  and vl: "vl = map TVal pstl @ OVal True # vll"
  and vl1: "vl1 = map TVal pstl1 @ OVal True # vll1"
  and rs: "reach s" and ss1: "eqButPID s s1" and op: "Â¬ open s" and PID: "PID ââ postIDs s"
  using reachNT_reach unfolding Î31_def by auto
  have vlvl1: "vl = [] â¹ vl1 = []" using t unfolding vl vl1 by auto
  have PID1: "PID ââ postIDs s1" using eqButPID_stateSelectors[OF ss1] PID by auto
  have own: "owner s PID â set (userIDs s)" using reach_owner_userIDs[OF rs PID] .
  hence own1: "owner s1 PID â set (userIDs s1)" using eqButPID_stateSelectors[OF ss1] by auto
  have op1: "Â¬ open s1" using op ss1 eqButPID_open by auto
  show "iaction ?Î s vl s1 vl1 â¨
        ((vl = [] â¶ vl1 = []) â§ reaction ?Î s vl s1 vl1)" (is "?iact â¨ (_ â§ ?react)")
  proof(cases "length pstl1 â¥ 2" )
    case True then obtain text1 pstll1 where pstl1: "pstl1 = text1 # pstll1"
    and pstll1: "pstll1 â  []" by (cases pstl1) fastforce+
    define uid where uid: "uid â¡ owner s PID"  define p where p: "p â¡ pass s uid"
    define a1 where a1: "a1 â¡ Uact (uPost uid p PID text1)"
    have uid1: "uid = owner s1 PID" and p1: "p = pass s1 uid" unfolding uid p
    using eqButPID_stateSelectors[OF ss1] by auto
    obtain ou1 s1' where step1: "step s1 a1 = (ou1, s1')" by(cases "step s1 a1") auto
    have ou1: "ou1 = outOK" using step1 PID1 own1 unfolding a1 uid1 p1 by (auto simp: u_defs)
    have op1': "Â¬ open s1'" using step1 op1 unfolding a1 ou1 open_defs by (auto simp: u_defs)
    have uid: "uid â UIDs" unfolding uid using op PID own unfolding open_defs by auto
    let ?trn1 = "Trans s1 a1 ou1 s1'"
    have ?iact proof
      show "step s1 a1 = (ou1, s1')" using step1 .
    next
      show Ï: "Ï ?trn1" unfolding Ï_def2[OF step1] a1 ou1 by simp
      show "consume ?trn1 vl1 (map TVal pstll1 @ OVal True # vll1)"
      using Ï unfolding vl1 consume_def pstl1 a1 by auto
    next
      show "Â¬ Î³ ?trn1" using uid unfolding a1 by auto
    next
      have "eqButPID s1 s1'" using Uact_uPost_step_eqButPID[OF _ step1] a1 by auto
      hence ss1': "eqButPID s s1'" using eqButPID_trans ss1 by blast
      have "Î31 s vl s1' (map TVal pstll1 @ OVal True # vll1)"
      using BO PID op t ss1' pstll1 unfolding Î31_def vl pstl1 by auto
      thus "?Î s vl s1' (map TVal pstll1 @ OVal True # vll1)" by simp
    qed
    thus ?thesis by simp
  next
    case False then obtain text1 where pstl1: "pstl1 = [text1]" using t
    by (cases pstl1) (auto simp: Suc_leI)
    have ?react proof
      fix a :: act and ou :: out and s' :: state and vl'
      let ?trn = "Trans s a ou s'"
      assume step: "step s a = (ou, s')" and T: "Â¬ T ?trn" and c: "consume ?trn vl vl'"
      obtain ou1 s1' where step1: "step s1 a = (ou1, s1')" by(cases "step s1 a") auto
      let ?trn1 = "Trans s1 a ou1 s1'"
      show "match ?Î s s1 vl1 a ou s' vl' â¨ ignore ?Î s s1 vl1 a ou s' vl'" (is "?match â¨ ?ignore")
      proof(cases "â uid p textt. a = Uact (uPost uid p PID textt) â§ ou = outOK")
        case True then obtain uid p textt where
        a: "a = Uact (uPost uid p PID textt)" and ou: "ou = outOK" by auto
        hence Ï: "Ï ?trn" unfolding Ï_def2[OF step] by auto
        then obtain "text" pstl' where pstl: "pstl = text # pstl'" and f: "f ?trn = TVal text"
        and vl': "vl' = map TVal pstl' @ OVal True # vll"
        using c t unfolding consume_def Ï_def2 vl by (cases pstl) auto
        have textt: "textt = text" using f unfolding a by auto
        have uid: "uid â UIDs" using step op PID unfolding a ou open_defs by (auto simp: u_defs)
        have "eqButPID s s'" using Uact_uPost_step_eqButPID[OF a step] by auto
        hence s's1: "eqButPID s' s1" using eqButPID_sym eqButPID_trans ss1 by blast
        have s's1': "s' = s1'" using step step1 ss1 eqButPID_step_eq unfolding a ou by blast
        have "e_updatePost s' uid p PID textt" using step unfolding a ou by(auto simp: u_defs)
        hence Ï1: "Ï ?trn1" using step1 unfolding a Ï_def2[OF step1] s's1' by auto
        hence f1: "f ?trn1 = TVal text" unfolding a textt by simp
        show ?thesis proof(cases "pstl' = []")
          case True note pstl' = True
          hence pstl: "pstl = [text]" unfolding pstl by auto
          hence text1: "text1 = text" using pstl pstl1 t by auto
          have PID': "PID ââ postIDs s'" using reach_postIDs_persist[OF PID step] .
          have op': "Â¬ open s'" using step PID' op unfolding a ou open_defs by (auto simp: u_defs)
          have ou1: "ou1 = outOK" using Ï1 op1 op' unfolding Ï_def2[OF step1] s's1' by auto
          have ?match proof
            show "validTrans ?trn1" using step1 by simp
          next
            show "consume ?trn1 vl1 (OVal True # vll1)"
            using Ï1 f1 unfolding consume_def vl1 pstl1 pstl text1 by simp
          next
            show "Î³ ?trn = Î³ ?trn1" unfolding ss1 by simp
          next
            assume "Î³ ?trn"
            show "g ?trn = g ?trn1" using ou ou1 by simp
          next
            have "Î32 s' vl' s1' (OVal True # vll1)"
            using s's1' BO PID' op' unfolding Î32_def vl' pstl' by auto
            thus "?Î s' vl' s1' (OVal True # vll1)" by simp
          qed
          thus ?thesis by simp
        next
          case False note pstl'NE = False
          have lpstl': "last pstl' = text1" using t pstl'NE unfolding pstl pstl1 by simp
          have ?ignore proof
            show "Â¬ Î³ ?trn" unfolding a using uid by auto
          next
            have PID': "PID ââ postIDs s'" using reach_postIDs_persist[OF PID step] .
            have op': "Â¬ open s'" using step PID' op unfolding a ou open_defs by (auto simp: u_defs)
            have ou1: "ou1 = outOK" using Ï1 op1 op' unfolding Ï_def2[OF step1] s's1' by auto
            have "Î31 s' vl' s1 vl1"
            using PID' s's1 op' BO pstl'NE lpstl' unfolding Î31_def vl' vl1 pstl1 by force
            thus "?Î s' vl' s1 vl1" by simp
          qed
          thus ?thesis by simp
        qed
      next
        case False note a = False
        {assume Ï: "Ï ?trn"
         then obtain "text" pstl' where pstl: "pstl = text # pstl'" and f: "f ?trn = TVal text"
         and vl': "vl' = map TVal pstl' @ OVal True # vll"
         using c t unfolding consume_def vl by (cases pstl) auto
         have False using f a Ï by (cases ?trn rule: Ï.cases) auto
        }
        hence Ï: "Â¬ Ï ?trn" by auto
        have op': "Â¬ open s'" using a op Ï unfolding Ï_def2[OF step] by auto
        have vl': "vl' = vl" using c Ï unfolding consume_def by auto
        have s's1': "eqButPID s' s1'" using eqButPID_step[OF ss1 step step1] .
        have op1': "Â¬ open s1'" using op' eqButPID_open[OF s's1'] by simp
        have "â uid p text. e_updatePost s1 uid p PID text â· e_updatePost s uid p PID text"
        using eqButPID_stateSelectors[OF ss1] unfolding u_defs by auto
        hence ou1: "â uid p text. a = Uact (uPost uid p PID text) â¹ ou1 = ou"
        using step step1 by auto
        hence Ï1: "Â¬ Ï ?trn1" using a op1 op1' unfolding Ï_def2[OF step1] by auto
        have ?match proof
          show "validTrans ?trn1" using step1 by simp
        next
          show "consume ?trn1 vl1 vl1" using Ï1 unfolding consume_def by simp
        next
          show "Î³ ?trn = Î³ ?trn1" unfolding ss1 by simp
        next
          assume "Î³ ?trn"
          hence "ou1 = ou" using eqButPID_step_Î³_out[OF ss1 step step1 op rsT rs1] by simp
          thus "g ?trn = g ?trn1" by simp
        next
          have PID': "PID ââ postIDs s'" using reach_postIDs_persist[OF PID step] .
          have "Î31 s' vl' s1' vl1" using s's1' op' PID' BO t
          unfolding Î31_def vl' vl vl1 pstl1 by fastforce
          thus "?Î s' vl' s1' vl1" by simp
        qed
      thus ?thesis by simp
      qed
    qed
    thus ?thesis using vlvl1 by simp
  qed
qed

lemma unwind_cont_Î32: "unwind_cont Î32 {Î2,Î32,Î4}"
proof(rule, simp)
  let ?Î = "Î»s vl s1 vl1. Î2 s vl s1 vl1 â¨ Î32 s vl s1 vl1 â¨ Î4 s vl s1 vl1"
  fix s s1 :: state and vl vl1 :: "value list"
  assume rsT: "reachNT s" and rs1: "reach s1" and "Î32 s vl s1 vl1"
  then obtain vll vll1 where BO: "BO vll vll1"
  and vl: "vl = OVal True # vll"
  and vl1: "vl1 = OVal True # vll1"
  and rs: "reach s" and ss1: "s1 = s" and op: "Â¬ open s" and PID: "PID ââ postIDs s"
  using reachNT_reach unfolding Î32_def by fastforce
  have vlvl1: "vl = [] â¹ vl1 = []" unfolding vl vl1 by auto
  show "iaction ?Î s vl s1 vl1 â¨
        ((vl = [] â¶ vl1 = []) â§ reaction ?Î s vl s1 vl1)" (is "?iact â¨ (_ â§ ?react)")
  proof-
    have ?react proof
      fix a :: act and ou :: out and s' :: state and vl'
      let ?trn = "Trans s a ou s'"
      assume step: "step s a = (ou, s')" and T: "Â¬ T ?trn" and c: "consume ?trn vl vl'"
      have PID': "PID ââ postIDs s'" using reach_postIDs_persist[OF PID step] .
      let ?trn1 = "Trans s1 a ou s'"
      show "match ?Î s s1 vl1 a ou s' vl' â¨ ignore ?Î s s1 vl1 a ou s' vl'" (is "?match â¨ ?ignore")
      proof
        show ?match proof(cases "Ï ?trn")
          case True note Ï = True
          hence f: "f ?trn = OVal True" and vl': "vl' = vll" using c unfolding consume_def vl by auto
          have op': "open s'" using op Ï f unfolding Ï_def2[OF step] by auto
          show ?thesis proof
            show "validTrans ?trn1" using step unfolding ss1 by simp
          next
            show "consume ?trn1 vl1 vll1" using Ï f unfolding consume_def vl1 ss1 by simp
          next
            show "Î³ ?trn = Î³ ?trn1" unfolding ss1 by simp
          next
            assume "Î³ ?trn"
            thus "g ?trn = g ?trn1" by simp
          next
            show "?Î s' vl' s' vll1" using BO proof(cases rule: BO.cases)
              case (BO_TVal pstll)
              hence "Î2 s' vl' s' vll1" using PID' op' unfolding Î2_def vl' by auto
              thus ?thesis by simp
            next
              case (BO_B vlll pstll)
              hence "Î4 s' vl' s' vll1" using PID' op' unfolding Î4_def vl' by auto
              thus ?thesis by simp
            qed
          qed
        next
          case False note Ï = False
          hence vl': "vl' = vl" using c unfolding consume_def vl by auto
          have op': "Â¬ open s'" using op Ï unfolding Ï_def2[OF step] by auto
          show ?thesis proof
            show "validTrans ?trn1" using step unfolding ss1 by simp
          next
            show "consume ?trn1 vl1 vl1" using Ï unfolding consume_def vl1 ss1 by simp
          next
            show "Î³ ?trn = Î³ ?trn1" unfolding ss1 by simp
          next
            assume "Î³ ?trn"
            thus "g ?trn = g ?trn1" by simp
          next
            have "Î32 s' vl' s' vl1" using BO PID' op' unfolding Î32_def vl' vl vl1 by simp
            thus "?Î s' vl' s' vl1" by simp
          qed
        qed
      qed
    qed
  thus ?thesis using vlvl1 by simp
  qed
qed

lemma unwind_cont_Î4: "unwind_cont Î4 {Î1,Î31,Î32,Î4}"
proof(rule, simp)
  let ?Î = "Î»s vl s1 vl1. Î1 s vl s1 vl1 â¨ Î31 s vl s1 vl1 â¨ Î32 s vl s1 vl1 â¨ Î4 s vl s1 vl1"
  fix s s1 :: state and vl vl1 :: "value list"
  assume rsT: "reachNT s" and rs1: "reach s1" and "Î4 s vl s1 vl1"
  then obtain pstl vll vll1 where B: "B vll vll1"
  and vl: "vl = map TVal pstl @ OVal False # vll" and vl1: "vl1 = map TVal pstl @ OVal False # vll1"
  and rs: "reach s" and ss1: "s1 = s" and op: "open s" and PID: "PID ââ postIDs s"
  using reachNT_reach unfolding Î4_def by fastforce
  have vlvl1: "vl = [] â¹ vl1 = []" unfolding vl vl1 by auto
  have own: "owner s PID â set (userIDs s)" using reach_owner_userIDs[OF rs PID] .
  show "iaction ?Î s vl s1 vl1 â¨
        ((vl = [] â¶ vl1 = []) â§ reaction ?Î s vl s1 vl1)" (is "?iact â¨ (_ â§ ?react)")
  proof-
    have ?react proof
      fix a :: act and ou :: out and s' :: state and vl'
      let ?trn = "Trans s a ou s'"  let ?trn1 = "Trans s1 a ou s'"
      assume step: "step s a = (ou, s')" and T: "Â¬ T ?trn" and c: "consume ?trn vl vl'"
      have PID': "PID ââ postIDs s'" using reach_postIDs_persist[OF PID step] .
      show "match ?Î s s1 vl1 a ou s' vl' â¨ ignore ?Î s s1 vl1 a ou s' vl'" (is "?match â¨ ?ignore")
      proof-
        have ?match proof(cases pstl)
          case (Cons "text" pstl') note pstl = Cons
          {assume op': "Â¬ open s'"
           hence Ï: "Ï ?trn" using op unfolding Ï_def2[OF step] by simp
           hence f: "f ?trn = TVal text"
           and vl': "vl' = map TVal pstl' @ OVal False # vll"
           using c unfolding consume_def vl pstl by auto
           obtain uid p where a: "a = Uact (uPost uid p PID text)" and ou: "ou = outOK"
             using f Ï by (cases ?trn rule: Ï.cases) auto
           have False using step op op' PID PID' unfolding a ou open_defs by (auto simp: u_defs)
          }
          hence op': "open s'" by auto
          show ?thesis proof(cases "Ï ?trn")
            case True note Ï = True
            hence f: "f ?trn = TVal text" and vl': "vl' = map TVal pstl' @ OVal False # vll"
            using c unfolding consume_def  vl pstl by auto
            obtain uid p textt where a: "a = Uact (uPost uid p PID textt)" and ou: "ou = outOK"
            using Ï op op' unfolding Ï_def2[OF step] by auto
            have textt: "textt = text" using f unfolding a by simp
            show ?thesis proof
              show "validTrans ?trn1" unfolding ss1 using step by simp
            next
              show "consume ?trn1 vl1 (map TVal pstl' @ OVal False # vll1)"
              using Ï unfolding ss1 consume_def vl1 vl vl' pstl f by auto
            next
              show "Î³ ?trn = Î³ ?trn1" unfolding ss1 by simp
            next
              assume "Î³ ?trn" thus "g ?trn = g ?trn1" unfolding ss1 by simp
            next
              have "Î4 s' vl' s' (map TVal pstl' @ OVal False # vll1)"
              using B PID' op' unfolding Î4_def vl1 vl' vl by auto
              thus "?Î s' vl' s' (map TVal pstl' @ OVal False # vll1)" by simp
            qed
          next
            case False note Ï = False
            hence vl': "vl' = vl" using c unfolding consume_def by auto
            show ?thesis proof
              show "validTrans ?trn1" unfolding ss1 using step by simp
            next
              show "consume ?trn1 vl1 vl1" using Ï unfolding ss1 consume_def vl1 vl vl' by auto
            next
              show "Î³ ?trn = Î³ ?trn1" unfolding ss1 by simp
            next
              assume "Î³ ?trn" thus "g ?trn = g ?trn1" unfolding ss1 by simp
            next
              have "Î4 s' vl' s' vl1"
              using B PID' op' unfolding Î4_def vl1 vl' vl by auto
              thus "?Î s' vl' s' vl1" by simp
            qed
          qed
        next
          case Nil note pstl = Nil
          show ?thesis proof(cases "Ï ?trn")
            case True note Ï = True
            hence f: "f ?trn = OVal False" and vl': "vl' = vll"
            using c unfolding consume_def vl pstl by auto
            hence op': "Â¬ open s'" using op step Ï unfolding Ï_def2[OF step] by auto
            show ?thesis proof
              show "validTrans ?trn1" unfolding ss1 using step by simp
            next
              show "consume ?trn1 vl1 vll1"
              using Ï unfolding ss1 consume_def vl1 vl vl' pstl f by auto
            next
              show "Î³ ?trn = Î³ ?trn1" unfolding ss1 by simp
            next
              assume "Î³ ?trn" thus "g ?trn = g ?trn1" unfolding ss1 by simp
            next
              show "?Î s' vl' s' vll1" using B proof(cases rule: B.cases)
                case (B_TVal pstlll pstlll1)
                hence "Î1 s' vl' s' vll1"
                using B PID' op' unfolding Î1_def vl1 vl' vl by auto
                thus ?thesis by simp
              next
                case (B_BO vlll vlll1 pstlll pstlll1)
                show ?thesis proof(cases "pstlll â  [] â§ pstlll1 â  []")
                  case True
                  hence "Î31 s' vl' s' vll1"
                  using B_BO B PID' op' unfolding Î31_def vl1 vl' vl by auto
                  thus ?thesis by simp
                next
                  case False
                  hence "Î32 s' vl' s' vll1"
                  using B_BO B PID' op' unfolding Î32_def vl1 vl' vl by auto
                  thus ?thesis by simp
                qed
              qed
            qed
          next
            case False note Ï = False
            hence vl': "vl' = vl" using c unfolding consume_def by auto
            have op': "open s'" using Ï op unfolding Ï_def2[OF step] by auto
            show ?thesis proof
              show "validTrans ?trn1" unfolding ss1 using step by simp
            next
              show "consume ?trn1 vl1 vl1" using Ï unfolding ss1 consume_def vl1 vl vl' by auto
            next
              show "Î³ ?trn = Î³ ?trn1" unfolding ss1 by simp
            next
              assume "Î³ ?trn" thus "g ?trn = g ?trn1" unfolding ss1 by simp
            next
              have "Î4 s' vl' s' vl1"
              using B PID' op' unfolding Î4_def vl1 vl' vl by auto
              thus "?Î s' vl' s' vl1" by simp
            qed
          qed
        qed
      thus ?thesis by simp
      qed
    qed
  thus ?thesis using vlvl1 by simp
  qed
qed

definition Gr where
"Gr =
 {
 (Î0, {Î0,Î1,Î2,Î31,Î32,Î4}),
 (Î1, {Î1}),
 (Î2, {Î2}),
 (Î31, {Î31,Î32}),
 (Î32, {Î2,Î32,Î4}),
 (Î4, {Î1,Î31,Î32,Î4})
 }"


theorem secure: secure
apply (rule unwind_decomp_secure_graph[of Gr Î0])
unfolding Gr_def
apply (simp, smt insert_subset order_refl)
using
istate_Î0 unwind_cont_Î0 unwind_cont_Î1
unwind_cont_Î31 unwind_cont_Î32 unwind_cont_Î2 unwind_cont_Î4
unfolding Gr_def by auto




end

theory Friend_Intro imports "../Safety_Properties" "../Observation_Setup" begin section â¹Friendship status confidentialityâº text â¹We prove the following property: \ \\ Given a group of users â¹UIDsâº and given two users â¹UID1âº and â¹UID2âº not in that group, that group cannot learn anything about the changes in the status of friendship between â¹UID1âº and â¹UID2âº beyond what everybody knows, namely that âª there is no friendship between â¹UID1âº and â¹UID2âº before those users have been created, and âª the updates form an alternating sequence of friending and unfriending, and beyond those updates performed while or last before a user in â¹UIDsâº is friends with â¹UID1âº or â¹UID2âº.âº end

(* The value setup for friend confidentiality *) theory Friend_Value_Setup imports Friend_Intro begin text â¹The confidential information is the friendship status between two arbitrary but fixed users:âº consts UID1 :: userID consts UID2 :: userID axiomatization where UID1_UID2_UIDs: "{UID1,UID2} â© UIDs = {}" and UID1_UID2: "UID1 â UID2" subsection â¹Preliminariesâº (* The notion of two userID lists being equal save for at most one occurrence of uid: *) fun eqButUIDl :: "userID â userID list â userID list â bool" where "eqButUIDl uid uidl uidl1 = (remove1 uid uidl = remove1 uid uidl1)" lemma eqButUIDl_eq[simp,intro!]: "eqButUIDl uid uidl uidl" by auto lemma eqButUIDl_sym: assumes "eqButUIDl uid uidl uidl1" shows "eqButUIDl uid uidl1 uidl" using assms by auto lemma eqButUIDl_trans: assumes "eqButUIDl uid uidl uidl1" and "eqButUIDl uid uidl1 uidl2" shows "eqButUIDl uid uidl uidl2" using assms by auto lemma eqButUIDl_remove1_cong: assumes "eqButUIDl uid uidl uidl1" shows "eqButUIDl uid (remove1 uid' uidl) (remove1 uid' uidl1)" proof - have "remove1 uid (remove1 uid' uidl) = remove1 uid' (remove1 uid uidl)" by (simp add: remove1_commute) also have "â¦ = remove1 uid' (remove1 uid uidl1)" using assms by simp also have "â¦ = remove1 uid (remove1 uid' uidl1)" by (simp add: remove1_commute) finally show ?thesis by simp qed lemma eqButUIDl_snoc_cong: assumes "eqButUIDl uid uidl uidl1" and "uid' ââ uidl â· uid' ââ uidl1" shows "eqButUIDl uid (uidl ## uid') (uidl1 ## uid')" using assms by (auto simp add: remove1_append remove1_idem) (* The notion of two functions each taking a userID and returning a list of user IDs being equal everywhere but on UID1 and UID2, where their return results are allowed to be eqButUIDl : *) definition eqButUIDf where "eqButUIDf frds frds1 â¡ eqButUIDl UID2 (frds UID1) (frds1 UID1) â§ eqButUIDl UID1 (frds UID2) (frds1 UID2) â§ (âuid. uid â UID1 â§ uid â UID2 â¶ frds uid = frds1 uid)" lemmas eqButUIDf_intro = eqButUIDf_def[THEN meta_eq_to_obj_eq, THEN iffD2] lemma eqButUIDf_eeq[simp,intro!]: "eqButUIDf frds frds" unfolding eqButUIDf_def by auto lemma eqButUIDf_sym: assumes "eqButUIDf frds frds1" shows "eqButUIDf frds1 frds" using assms eqButUIDl_sym unfolding eqButUIDf_def by presburger lemma eqButUIDf_trans: assumes "eqButUIDf frds frds1" and "eqButUIDf frds1 frds2" shows "eqButUIDf frds frds2" using assms eqButUIDl_trans unfolding eqButUIDf_def by (auto split: if_splits) lemma eqButUIDf_cong: assumes "eqButUIDf frds frds1" and "uid = UID1 â¹ eqButUIDl UID2 uu uu1" and "uid = UID2 â¹ eqButUIDl UID1 uu uu1" and "uid â UID1 â¹ uid â UID2 â¹ uu = uu1" shows "eqButUIDf (frds (uid := uu)) (frds1(uid := uu1))" using assms unfolding eqButUIDf_def by (auto split: if_splits) lemma eqButUIDf_eqButUIDl: assumes "eqButUIDf frds frds1" shows "eqButUIDl UID2 (frds UID1) (frds1 UID1)" and "eqButUIDl UID1 (frds UID2) (frds1 UID2)" using assms unfolding eqButUIDf_def by (auto split: if_splits) lemma eqButUIDf_not_UID: "â¦eqButUIDf frds frds1; uid â UID1; uid â UID2â§ â¹ frds uid = frds1 uid" unfolding eqButUIDf_def by (auto split: if_splits) lemma eqButUIDf_not_UID': assumes eq1: "eqButUIDf frds frds1" and uid: "(uid,uid') â {(UID1,UID2), (UID2,UID1)}" shows "uid ââ frds uid' â· uid ââ frds1 uid'" proof - from uid have "(uid' = UID1 â§ uid â UID2) â¨ (uid' = UID2 â§ uid â UID1) â¨ (uid' â {UID1,UID2})" (is "?u1 â¨ ?u2 â¨ ?n12") by auto then show ?thesis proof (elim disjE) assume "?u1" moreover then have "uid ââ remove1 UID2 (frds uid') â· uid ââ remove1 UID2 (frds1 uid')" using eq1 unfolding eqButUIDf_def by auto ultimately show ?thesis by auto next assume "?u2" moreover then have "uid ââ remove1 UID1 (frds uid') â· uid ââ remove1 UID1 (frds1 uid')" using eq1 unfolding eqButUIDf_def by auto ultimately show ?thesis by auto next assume "?n12" then show ?thesis using eq1 unfolding eqButUIDf_def by auto qed qed (* The notion of two functions each taking two userID arguments being equal everywhere but on the values (UID1,UID2) and (UID2,UID1): *) definition eqButUID12 where "eqButUID12 freq freq1 â¡ â uid uid'. if (uid,uid') â {(UID1,UID2), (UID2,UID1)} then True else freq uid uid' = freq1 uid uid'" lemmas eqButUID12_intro = eqButUID12_def[THEN meta_eq_to_obj_eq, THEN iffD2] lemma eqButUID12_eeq[simp,intro!]: "eqButUID12 freq freq" unfolding eqButUID12_def by auto lemma eqButUID12_sym: assumes "eqButUID12 freq freq1" shows "eqButUID12 freq1 freq" using assms unfolding eqButUID12_def by presburger lemma eqButUID12_trans: assumes "eqButUID12 freq freq1" and "eqButUID12 freq1 freq2" shows "eqButUID12 freq freq2" using assms unfolding eqButUID12_def by (auto split: if_splits) lemma eqButUID12_cong: assumes "eqButUID12 freq freq1" (*and "uid = UID1 â¹ eqButUID2 uu uu1"*) and "Â¬ (uid,uid') â {(UID1,UID2), (UID2,UID1)} â¹ uu = uu1" shows "eqButUID12 (fun_upd2 freq uid uid' uu) (fun_upd2 freq1 uid uid' uu1)" using assms unfolding eqButUID12_def fun_upd2_def by (auto split: if_splits) lemma eqButUID12_not_UID: "â¦eqButUID12 freq freq1; Â¬ (uid,uid') â {(UID1,UID2), (UID2,UID1)}â§ â¹ freq uid uid' = freq1 uid uid'" unfolding eqButUID12_def by (auto split: if_splits) (* The notion of two states being equal everywhere but on the friendship requests or status of users UID1 and UID2: *) definition eqButUID :: "state â state â bool" where "eqButUID s s1 â¡ admin s = admin s1 â§ pendingUReqs s = pendingUReqs s1 â§ userReq s = userReq s1 â§ userIDs s = userIDs s1 â§ user s = user s1 â§ pass s = pass s1 â§ eqButUIDf (pendingFReqs s) (pendingFReqs s1) â§ eqButUID12 (friendReq s) (friendReq s1) â§ eqButUIDf (friendIDs s) (friendIDs s1) â§ postIDs s = postIDs s1 â§ admin s = admin s1 â§ post s = post s1 â§ owner s = owner s1 â§ vis s = vis s1" lemmas eqButUID_intro = eqButUID_def[THEN meta_eq_to_obj_eq, THEN iffD2] lemma eqButUID_refl[simp,intro!]: "eqButUID s s" unfolding eqButUID_def by auto lemma eqButUID_sym[sym]: assumes "eqButUID s s1" shows "eqButUID s1 s" using assms eqButUIDf_sym eqButUID12_sym unfolding eqButUID_def by auto lemma eqButUID_trans[trans]: assumes "eqButUID s s1" and "eqButUID s1 s2" shows "eqButUID s s2" using assms eqButUIDf_trans eqButUID12_trans unfolding eqButUID_def by metis (* Implications from eqButUID, including w.r.t. auxiliary operations: *) lemma eqButUID_stateSelectors: "eqButUID s s1 â¹ admin s = admin s1 â§ pendingUReqs s = pendingUReqs s1 â§ userReq s = userReq s1 â§ userIDs s = userIDs s1 â§ user s = user s1 â§ pass s = pass s1 â§ eqButUIDf (pendingFReqs s) (pendingFReqs s1) â§ eqButUID12 (friendReq s) (friendReq s1) â§ eqButUIDf (friendIDs s) (friendIDs s1) â§ postIDs s = postIDs s1 â§ admin s = admin s1 â§ post s = post s1 â§ owner s = owner s1 â§ vis s = vis s1 â§ IDsOK s = IDsOK s1" unfolding eqButUID_def IDsOK_def[abs_def] by auto lemma eqButUID_eqButUID2: "eqButUID s s1 â¹ eqButUIDl UID2 (friendIDs s UID1) (friendIDs s1 UID1)" unfolding eqButUID_def using eqButUIDf_eqButUIDl by (smt eqButUIDf_eqButUIDl eqButUIDl.simps) lemma eqButUID_not_UID: "eqButUID s s1 â¹ uid â UID â¹ post s uid = post s1 uid" unfolding eqButUID_def by auto lemma eqButUID_cong[simp, intro]: "â uu1 uu2. eqButUID s s1 â¹ uu1 = uu2 â¹ eqButUID (s â¦admin := uu1â¦) (s1 â¦admin := uu2â¦)" "â uu1 uu2. eqButUID s s1 â¹ uu1 = uu2 â¹ eqButUID (s â¦pendingUReqs := uu1â¦) (s1 â¦pendingUReqs := uu2â¦)" "â uu1 uu2. eqButUID s s1 â¹ uu1 = uu2 â¹ eqButUID (s â¦userReq := uu1â¦) (s1 â¦userReq := uu2â¦)" "â uu1 uu2. eqButUID s s1 â¹ uu1 = uu2 â¹ eqButUID (s â¦userIDs := uu1â¦) (s1 â¦userIDs := uu2â¦)" "â uu1 uu2. eqButUID s s1 â¹ uu1 = uu2 â¹ eqButUID (s â¦user := uu1â¦) (s1 â¦user := uu2â¦)" "â uu1 uu2. eqButUID s s1 â¹ uu1 = uu2 â¹ eqButUID (s â¦pass := uu1â¦) (s1 â¦pass := uu2â¦)" "â uu1 uu2. eqButUID s s1 â¹ uu1 = uu2 â¹ eqButUID (s â¦postIDs := uu1â¦) (s1 â¦postIDs := uu2â¦)" "â uu1 uu2. eqButUID s s1 â¹ uu1 = uu2 â¹ eqButUID (s â¦owner := uu1â¦) (s1 â¦owner := uu2â¦)" "â uu1 uu2. eqButUID s s1 â¹ uu1 = uu2 â¹ eqButUID (s â¦post := uu1â¦) (s1 â¦post := uu2â¦)" "â uu1 uu2. eqButUID s s1 â¹ uu1 = uu2 â¹ eqButUID (s â¦vis := uu1â¦) (s1 â¦vis := uu2â¦)" "â uu1 uu2. eqButUID s s1 â¹ eqButUIDf uu1 uu2 â¹ eqButUID (s â¦pendingFReqs := uu1â¦) (s1 â¦pendingFReqs := uu2â¦)" "â uu1 uu2. eqButUID s s1 â¹ eqButUID12 uu1 uu2 â¹ eqButUID (s â¦friendReq := uu1â¦) (s1 â¦friendReq := uu2â¦)" "â uu1 uu2. eqButUID s s1 â¹ eqButUIDf uu1 uu2 â¹ eqButUID (s â¦friendIDs := uu1â¦) (s1 â¦friendIDs := uu2â¦)" unfolding eqButUID_def by auto subsectionâ¹Value Setupâº datatype "value" = FrVal bool â â¹updated friendship status between â¹UID1âº and â¹UID2âºâº | OVal bool â â¹updated dynamic declassification trigger conditionâº text â¹The dynamic declassification trigger condition holds, i.e.~the access window to the confidential information is open, as long as the two users have not been created yet (so there cannot be friendship between them) or one of them is friends with an observer.âº definition openByA :: "state â bool" â â¹Openness by absenceâº where "openByA s â¡ Â¬ UID1 ââ userIDs s â¨ Â¬ UID2 ââ userIDs s" definition openByF :: "state â bool" â â¹Openness by friendshipâº where "openByF s â¡ âuid â UIDs. uid ââ friendIDs s UID1 â¨ uid ââ friendIDs s UID2" definition "open" :: "state â bool" where "open s â¡ openByA s â¨ openByF s" lemmas open_defs = open_def openByA_def openByF_def definition "friends12" :: "state â bool" where "friends12 s â¡ UID1 ââ friendIDs s UID2 â§ UID2 ââ friendIDs s UID1" fun Ï :: "(state,act,out) trans â bool" where "Ï (Trans s (Cact (cFriend uid p uid')) ou s') = ((uid,uid') â {(UID1,UID2), (UID2,UID1)} â§ ou = outOK â¨ open s â open s')" | "Ï (Trans s (Dact (dFriend uid p uid')) ou s') = ((uid,uid') â {(UID1,UID2), (UID2,UID1)} â§ ou = outOK â¨ open s â open s')" | "Ï (Trans s (Cact (cUser uid p uid' p')) ou s') = (open s â open s')" | "Ï _ = False" fun f :: "(state,act,out) trans â value" where "f (Trans s (Cact (cFriend uid p uid')) ou s') = (if (uid,uid') â {(UID1,UID2), (UID2,UID1)} then FrVal True else OVal True)" | "f (Trans s (Dact (dFriend uid p uid')) ou s') = (if (uid,uid') â {(UID1,UID2), (UID2,UID1)} then FrVal False else OVal False)" | "f (Trans s (Cact (cUser uid p uid' p')) ou s') = OVal False" | "f _ = undefined" lemma ÏE: assumes Ï: "Ï (Trans s a ou s')" (is "Ï ?trn") and step: "step s a = (ou, s')" and rs: "reach s" obtains (Friend) uid p uid' where "a = Cact (cFriend uid p uid')" "ou = outOK" "f ?trn = FrVal True" "uid = UID1 â§ uid' = UID2 â¨ uid = UID2 â§ uid' = UID1" "IDsOK s [UID1, UID2] []" "Â¬friends12 s" "friends12 s'" | (Unfriend) uid p uid' where "a = Dact (dFriend uid p uid')" "ou = outOK" "f ?trn = FrVal False" "uid = UID1 â§ uid' = UID2 â¨ uid = UID2 â§ uid' = UID1" "IDsOK s [UID1, UID2] []" "friends12 s" "Â¬friends12 s'" | (OpenF) uid p uid' where "a = Cact (cFriend uid p uid')" "(uid â UIDs â§ uid' â {UID1,UID2}) â¨ (uid' â UIDs â§ uid â {UID1,UID2})" "ou = outOK" "f ?trn = OVal True" "Â¬openByF s" "openByF s'" "Â¬openByA s" "Â¬openByA s'" | (CloseF) uid p uid' where "a = Dact (dFriend uid p uid')" "(uid â UIDs â§ uid' â {UID1,UID2}) â¨ (uid' â UIDs â§ uid â {UID1,UID2})" "ou = outOK" "f ?trn = OVal False" "openByF s" "Â¬openByF s'" "Â¬openByA s" "Â¬openByA s'" | (CloseA) uid p uid' p' where "a = Cact (cUser uid p uid' p')" "uid' â {UID1,UID2}" "openByA s" "Â¬openByA s'" "Â¬openByF s" "Â¬openByF s'" "ou = outOK" "f ?trn = OVal False" using Ï proof (elim Ï.elims disjE conjE) fix s1 uid p uid' ou1 s1' assume "(uid,uid') â {(UID1,UID2), (UID2,UID1)}" and ou: "ou1 = outOK" and "?trn = Trans s1 (Cact (cFriend uid p uid')) ou1 s1'" then have trn: "a = Cact (cFriend uid p uid')" "s = s1" "s' = s1'" "ou = ou1" and uids: "uid = UID1 â§ uid' = UID2 â¨ uid = UID2 â§ uid' = UID1" using UID1_UID2 by auto then show thesis using ou uids trn step UID1_UID2_UIDs UID1_UID2 reach_distinct_friends_reqs[OF rs] by (intro Friend[of uid p uid']) (auto simp add: c_defs friends12_def) next fix s1 uid p uid' ou1 s1' assume op: "open s1 â open s1'" and "?trn = Trans s1 (Cact (cFriend uid p uid')) ou1 s1'" then have trn: "a = Cact (cFriend uid p uid')" "s = s1" "s' = s1'" "ou = ou1" by auto then have uids: "uid â UIDs â§ uid' â {UID1, UID2} â¨ uid â {UID1, UID2} â§ uid' â UIDs" "ou = outOK" "Â¬openByF s1" "openByF s1'" "Â¬openByA s1" "Â¬openByA s1'" using op step by (auto simp add: c_defs open_def openByA_def openByF_def) then show thesis using op trn step UID1_UID2_UIDs UID1_UID2 by (intro OpenF) auto next fix s1 uid p uid' ou1 s1' assume "(uid,uid') â {(UID1,UID2), (UID2,UID1)}" and ou: "ou1 = outOK" and "?trn = Trans s1 (Dact (dFriend uid p uid')) ou1 s1'" then have trn: "a = Dact (dFriend uid p uid')" "s = s1" "s' = s1'" "ou = ou1" and uids: "uid = UID1 â§ uid' = UID2 â¨ uid = UID2 â§ uid' = UID1" using UID1_UID2 by auto then show thesis using step ou reach_friendIDs_symmetric[OF rs] by (intro Unfriend) (auto simp: d_defs friends12_def) next fix s1 uid p uid' ou1 s1' assume op: "open s1 â open s1'" and "?trn = Trans s1 (Dact (dFriend uid p uid')) ou1 s1'" then have trn: "a = Dact (dFriend uid p uid')" "s = s1" "s' = s1'" "ou = ou1" by auto then have uids: "uid â UIDs â§ uid' â {UID1, UID2} â¨ uid â {UID1, UID2} â§ uid' â UIDs" "ou = outOK" "openByF s1" "Â¬openByF s1'" "Â¬openByA s1" "Â¬openByA s1'" using op step by (auto simp add: d_defs open_def openByA_def openByF_def) then show thesis using op trn step UID1_UID2_UIDs UID1_UID2 by (auto intro: CloseF) next fix s1 uid p uid' p' ou1 s1' assume op: "open s1 â open s1'" and "?trn = Trans s1 (Cact (cUser uid p uid' p')) ou1 s1'" then have trn: "a = Cact (cUser uid p uid' p')" "s = s1" "s' = s1'" "ou = ou1" by auto then have uids: "uid' = UID2 â¨ uid' = UID1" "ou = outOK" "Â¬openByF s1" "Â¬openByF s1'" "openByA s1" "Â¬openByA s1'" using op step by (auto simp add: c_defs open_def openByF_def openByA_def) then show thesis using trn step UID1_UID2_UIDs UID1_UID2 by (intro CloseA) auto qed lemma step_open_Ï: assumes "step s a = (ou, s')" and "open s â open s'" shows "Ï (Trans s a ou s')" using assms proof (cases a) case (Sact sa) then show ?thesis using assms UID1_UID2 by (cases sa) (auto simp: s_defs open_defs) next case (Cact ca) then show ?thesis using assms by (cases ca) (auto simp: c_defs open_defs) next case (Dact da) then show ?thesis using assms by (cases da) (auto simp: d_defs open_defs) next case (Uact ua) then show ?thesis using assms by (cases ua) (auto simp: u_defs open_defs) qed auto lemma step_friends12_Ï: assumes "step s a = (ou, s')" and "friends12 s â friends12 s'" shows "Ï (Trans s a ou s')" using assms proof (cases a) case (Sact sa) then show ?thesis using assms by (cases sa) (auto simp: s_defs friends12_def) next case (Cact ca) then show ?thesis using assms by (cases ca) (auto simp: c_defs friends12_def) next case (Dact da) then show ?thesis using assms by (cases da) (auto simp: d_defs friends12_def) next case (Uact ua) then show ?thesis using assms by (cases ua) (auto simp: u_defs friends12_def) qed auto lemma eqButUID_friends12_set_friendIDs_eq: assumes ss1: "eqButUID s s1" and f12: "friends12 s = friends12 s1" and rs: "reach s" and rs1: "reach s1" shows "set (friendIDs s uid) = set (friendIDs s1 uid)" proof - have dfIDs: "distinct (friendIDs s uid)" "distinct (friendIDs s1 uid)" using reach_distinct_friends_reqs[OF rs] reach_distinct_friends_reqs[OF rs1] by auto from f12 have uid12: "UID1 ââ friendIDs s UID2 â· UID1 ââ friendIDs s1 UID2" "UID2 ââ friendIDs s UID1 â· UID2 ââ friendIDs s1 UID1" using reach_friendIDs_symmetric[OF rs] reach_friendIDs_symmetric[OF rs1] unfolding friends12_def by auto from ss1 have fIDs: "eqButUIDf (friendIDs s) (friendIDs s1)" unfolding eqButUID_def by simp show "set (friendIDs s uid) = set (friendIDs s1 uid)" proof (intro equalityI subsetI) fix uid' assume "uid' ââ friendIDs s uid" then show "uid' ââ friendIDs s1 uid" using fIDs dfIDs uid12 eqButUIDf_not_UID' unfolding eqButUIDf_def by (metis (no_types, lifting) insert_iff prod.inject singletonD) next fix uid' assume "uid' ââ friendIDs s1 uid" then show "uid' ââ friendIDs s uid" using fIDs dfIDs uid12 eqButUIDf_not_UID' unfolding eqButUIDf_def by (metis (no_types, lifting) insert_iff prod.inject singletonD) qed qed lemma distinct_remove1_idem: "distinct xs â¹ remove1 y (remove1 y xs) = remove1 y xs" by (induction xs) (auto simp add: remove1_idem) lemma Cact_cFriend_step_eqButUID: assumes step: "step s (Cact (cFriend uid p uid')) = (ou,s')" and s: "reach s" and uids: "(uid = UID1 â§ uid' = UID2) â¨ (uid = UID2 â§ uid' = UID1)" (is "?u12 â¨ ?u21") shows "eqButUID s s'" using assms proof (cases) assume ou: "ou = outOK" then have "uid' ââ pendingFReqs s uid" using step by (auto simp add: c_defs) then have fIDs: "uid' â set (friendIDs s uid)" "uid â set (friendIDs s uid')" and fRs: "distinct (pendingFReqs s uid)" "distinct (pendingFReqs s uid')" using reach_distinct_friends_reqs[OF s] by auto have "eqButUIDf (friendIDs s) (friendIDs (createFriend s uid p uid'))" using fIDs uids UID1_UID2 unfolding eqButUIDf_def by (cases "?u12") (auto simp add: c_defs remove1_idem remove1_append) moreover have "eqButUIDf (pendingFReqs s) (pendingFReqs (createFriend s uid p uid'))" using fRs uids UID1_UID2 unfolding eqButUIDf_def by (cases "?u12") (auto simp add: c_defs distinct_remove1_idem) moreover have "eqButUID12 (friendReq s) (friendReq (createFriend s uid p uid'))" using uids unfolding eqButUID12_def by (auto simp add: c_defs fun_upd2_eq_but_a_b) ultimately show "eqButUID s s'" using step ou unfolding eqButUID_def by (auto simp add: c_defs) qed (auto) lemma Cact_cFriendReq_step_eqButUID: assumes step: "step s (Cact (cFriendReq uid p uid' req)) = (ou,s')" and uids: "(uid = UID1 â§ uid' = UID2) â¨ (uid = UID2 â§ uid' = UID1)" (is "?u12 â¨ ?u21") shows "eqButUID s s'" using assms proof (cases) assume ou: "ou = outOK" then have "uid â set (pendingFReqs s uid')" "uid â set (friendIDs s uid')" using step by (auto simp add: c_defs) then have "eqButUIDf (pendingFReqs s) (pendingFReqs (createFriendReq s uid p uid' req))" using uids UID1_UID2 unfolding eqButUIDf_def by (cases "?u12") (auto simp add: c_defs remove1_idem remove1_append) moreover have "eqButUID12 (friendReq s) (friendReq (createFriendReq s uid p uid' req))" using uids unfolding eqButUID12_def by (auto simp add: c_defs fun_upd2_eq_but_a_b) ultimately show "eqButUID s s'" using step ou unfolding eqButUID_def by (auto simp add: c_defs) qed (auto) lemma Dact_dFriend_step_eqButUID: assumes step: "step s (Dact (dFriend uid p uid')) = (ou,s')" and s: "reach s" and uids: "(uid = UID1 â§ uid' = UID2) â¨ (uid = UID2 â§ uid' = UID1)" (is "?u12 â¨ ?u21") shows "eqButUID s s'" using assms proof (cases) assume ou: "ou = outOK" then have "uid' ââ friendIDs s uid" using step by (auto simp add: d_defs) then have fRs: "distinct (friendIDs s uid)" "distinct (friendIDs s uid')" using reach_distinct_friends_reqs[OF s] by auto have "eqButUIDf (friendIDs s) (friendIDs (deleteFriend s uid p uid'))" using fRs uids UID1_UID2 unfolding eqButUIDf_def by (cases "?u12") (auto simp add: d_defs remove1_idem distinct_remove1_removeAll) then show "eqButUID s s'" using step ou unfolding eqButUID_def by (auto simp add: d_defs) qed (auto) (* Key lemma: *) lemma eqButUID_step: assumes ss1: "eqButUID s s1" and step: "step s a = (ou,s')" and step1: "step s1 a = (ou1,s1')" and rs: "reach s" and rs1: "reach s1" shows "eqButUID s' s1'" proof - note simps = eqButUID_def s_defs c_defs u_defs r_defs l_defs from assms show ?thesis proof (cases a) case (Sact sa) with assms show ?thesis by (cases sa) (auto simp add: simps) next case (Cact ca) note a = this with assms show ?thesis proof (cases ca) case (cFriendReq uid p uid' req) note ca = this then show ?thesis proof (cases "(uid = UID1 â§ uid' = UID2) â¨ (uid = UID2 â§ uid' = UID1)") case True then have "eqButUID s s'" and "eqButUID s1 s1'" using step step1 unfolding a ca by (auto intro: Cact_cFriendReq_step_eqButUID) with ss1 show "eqButUID s' s1'" by (auto intro: eqButUID_sym eqButUID_trans) next case False have fRs: "eqButUIDf (pendingFReqs s) (pendingFReqs s1)" and fIDs: "eqButUIDf (friendIDs s) (friendIDs s1)" using ss1 by (auto simp: simps) then have uid_uid': "uid ââ pendingFReqs s uid' â· uid ââ pendingFReqs s1 uid'" "uid ââ friendIDs s uid' â· uid ââ friendIDs s1 uid'" using False by (auto intro!: eqButUIDf_not_UID') have "eqButUIDf ((pendingFReqs s)(uid' := pendingFReqs s uid' ## uid)) ((pendingFReqs s1)(uid' := pendingFReqs s1 uid' ## uid))" using fRs False by (intro eqButUIDf_cong) (auto simp add: remove1_append remove1_idem eqButUIDf_def) moreover have "eqButUID12 (fun_upd2 (friendReq s) uid uid' req) (fun_upd2 (friendReq s1) uid uid' req)" using ss1 by (intro eqButUID12_cong) (auto simp: simps) moreover have "e_createFriendReq s uid p uid' req â· e_createFriendReq s1 uid p uid' req" using uid_uid' ss1 by (auto simp: simps) ultimately show ?thesis using assms unfolding a ca by (auto simp: simps) qed next case (cFriend uid p uid') note ca = this then show ?thesis proof (cases "(uid = UID1 â§ uid' = UID2) â¨ (uid = UID2 â§ uid' = UID1)") case True then have "eqButUID s s'" and "eqButUID s1 s1'" using step step1 rs rs1 unfolding a ca by (auto intro!: Cact_cFriend_step_eqButUID)+ with ss1 show "eqButUID s' s1'" by (auto intro: eqButUID_sym eqButUID_trans) next case False have fRs: "eqButUIDf (pendingFReqs s) (pendingFReqs s1)" (is "eqButUIDf (?pfr s) (?pfr s1)") and fIDs: "eqButUIDf (friendIDs s) (friendIDs s1)" using ss1 by (auto simp: simps) then have uid_uid': "uid ââ pendingFReqs s uid' â· uid ââ pendingFReqs s1 uid'" "uid' ââ pendingFReqs s uid â· uid' ââ pendingFReqs s1 uid" "uid ââ friendIDs s uid' â· uid ââ friendIDs s1 uid'" "uid' ââ friendIDs s uid â· uid' ââ friendIDs s1 uid" using False by (auto intro!: eqButUIDf_not_UID') have "eqButUIDl UID1 (remove1 uid' (?pfr s UID2)) (remove1 uid' (?pfr s1 UID2))" and "eqButUIDl UID2 (remove1 uid' (?pfr s UID1)) (remove1 uid' (?pfr s1 UID1))" and "eqButUIDl UID1 (remove1 uid (?pfr s UID2)) (remove1 uid (?pfr s1 UID2))" and "eqButUIDl UID2 (remove1 uid (?pfr s UID1)) (remove1 uid (?pfr s1 UID1))" using fRs unfolding eqButUIDf_def by (auto intro!: eqButUIDl_remove1_cong simp del: eqButUIDl.simps) then have 1: "eqButUIDf ((?pfr s)(uid := remove1 uid' (?pfr s uid), uid' := remove1 uid (?pfr s uid'))) ((?pfr s1)(uid := remove1 uid' (?pfr s1 uid), uid' := remove1 uid (?pfr s1 uid')))" using fRs False by (intro eqButUIDf_cong) (auto simp add: eqButUIDf_def) have "uid = UID1 â¹ eqButUIDl UID2 (friendIDs s UID1 ## uid') (friendIDs s1 UID1 ## uid')" and "uid = UID2 â¹ eqButUIDl UID1 (friendIDs s UID2 ## uid') (friendIDs s1 UID2 ## uid')" and "uid' = UID1 â¹ eqButUIDl UID2 (friendIDs s UID1 ## uid) (friendIDs s1 UID1 ## uid)" and "uid' = UID2 â¹ eqButUIDl UID1 (friendIDs s UID2 ## uid) (friendIDs s1 UID2 ## uid)" using fIDs uid_uid' by - (intro eqButUIDl_snoc_cong; simp add: eqButUIDf_def)+ then have 2: "eqButUIDf ((friendIDs s)(uid := friendIDs s uid ## uid', uid' := friendIDs s uid' ## uid)) ((friendIDs s1)(uid := friendIDs s1 uid ## uid', uid' := friendIDs s1 uid' ## uid))" using fIDs by (intro eqButUIDf_cong) (auto simp add: eqButUIDf_def) have 3: "eqButUID12 (fun_upd2 (fun_upd2 (friendReq s) uid' uid emptyReq) uid uid' emptyReq) (fun_upd2 (fun_upd2 (friendReq s1) uid' uid emptyReq) uid uid' emptyReq)" using ss1 by (intro eqButUID12_cong) (auto simp: simps) have "e_createFriend s uid p uid' â· e_createFriend s1 uid p uid'" using uid_uid' ss1 by (auto simp: simps) with 1 2 3 show ?thesis using assms unfolding a ca by (auto simp: simps) qed qed (auto simp: simps) next case (Uact ua) with assms show ?thesis by (cases ua) (auto simp add: simps) next case (Ract ra) with assms show ?thesis by (cases ra) (auto simp add: simps) next case (Lact la) with assms show ?thesis by (cases la) (auto simp add: simps) next case (Dact da) note a = this with assms show ?thesis proof (cases da) case (dFriend uid p uid') note ca = this then show ?thesis proof (cases "(uid = UID1 â§ uid' = UID2) â¨ (uid = UID2 â§ uid' = UID1)") case True then have "eqButUID s s'" and "eqButUID s1 s1'" using step step1 rs rs1 unfolding a ca by (auto intro!: Dact_dFriend_step_eqButUID)+ with ss1 show "eqButUID s' s1'" by (auto intro: eqButUID_sym eqButUID_trans) next case False have fIDs: "eqButUIDf (friendIDs s) (friendIDs s1)" using ss1 by (auto simp: simps) then have uid_uid': "uid ââ friendIDs s uid' â· uid ââ friendIDs s1 uid'" "uid' ââ friendIDs s uid â· uid' ââ friendIDs s1 uid" using False by (auto intro!: eqButUIDf_not_UID') have dfIDs: "distinct (friendIDs s uid)" "distinct (friendIDs s uid')" "distinct (friendIDs s1 uid)" "distinct (friendIDs s1 uid')" using reach_distinct_friends_reqs[OF rs] reach_distinct_friends_reqs[OF rs1] by auto have "uid = UID1 â¹ eqButUIDl UID2 (remove1 uid' (friendIDs s UID1)) (remove1 uid' (friendIDs s1 UID1))" and "uid = UID2 â¹ eqButUIDl UID1 (remove1 uid' (friendIDs s UID2)) (remove1 uid' (friendIDs s1 UID2))" and "uid' = UID1 â¹ eqButUIDl UID2 (remove1 uid (friendIDs s UID1)) (remove1 uid (friendIDs s1 UID1))" and "uid' = UID2 â¹ eqButUIDl UID1 (remove1 uid (friendIDs s UID2)) (remove1 uid (friendIDs s1 UID2))" using fIDs uid_uid' by - (intro eqButUIDl_remove1_cong; simp add: eqButUIDf_def)+ then have 1: "eqButUIDf ((friendIDs s)(uid := remove1 uid' (friendIDs s uid), uid' := remove1 uid (friendIDs s uid'))) ((friendIDs s1)(uid := remove1 uid' (friendIDs s1 uid), uid' := remove1 uid (friendIDs s1 uid')))" using fIDs by (intro eqButUIDf_cong) (auto simp add: eqButUIDf_def) have "e_deleteFriend s uid p uid' â· e_deleteFriend s1 uid p uid'" using uid_uid' ss1 by (auto simp: simps d_defs) with 1 show ?thesis using assms dfIDs unfolding a ca by (auto simp: simps d_defs distinct_remove1_removeAll) qed qed qed qed lemma eqButUID_openByA_eq: assumes "eqButUID s s1" shows "openByA s = openByA s1" using assms unfolding openByA_def eqButUID_def by auto lemma eqButUID_openByF_eq: assumes ss1: "eqButUID s s1" shows "openByF s = openByF s1" proof - from ss1 have fIDs: "eqButUIDf (friendIDs s) (friendIDs s1)" unfolding eqButUID_def by auto have "âuid â UIDs. uid ââ friendIDs s UID1 â· uid ââ friendIDs s1 UID1" using UID1_UID2_UIDs UID1_UID2 by (intro ballI eqButUIDf_not_UID'[OF fIDs]; auto) moreover have "âuid â UIDs. uid ââ friendIDs s UID2 â· uid ââ friendIDs s1 UID2" using UID1_UID2_UIDs UID1_UID2 by (intro ballI eqButUIDf_not_UID'[OF fIDs]; auto) ultimately show "openByF s = openByF s1" unfolding openByF_def by auto qed lemma eqButUID_open_eq: "eqButUID s s1 â¹ open s = open s1" using eqButUID_openByA_eq eqButUID_openByF_eq unfolding open_def by blast lemma eqButUID_step_friendIDs_eq: assumes ss1: "eqButUID s s1" and rs: "reach s" and rs1: "reach s1" and step: "step s a = (ou,s')" and step1: "step s1 a = (ou1,s1')" and a: "a â Cact (cFriend UID1 (pass s UID1) UID2) â§ a â Cact (cFriend UID2 (pass s UID2) UID1) â§ a â Dact (dFriend UID1 (pass s UID1) UID2) â§ a â Dact (dFriend UID2 (pass s UID2) UID1)" and "friendIDs s = friendIDs s1" shows "friendIDs s' = friendIDs s1'" using assms proof (cases a) case (Sact sa) then show ?thesis using assms by (cases sa) (auto simp: s_defs) next case (Uact ua) then show ?thesis using assms by (cases ua) (auto simp: u_defs) next case (Dact da) then show ?thesis using assms proof (cases da) case (dFriend uid p uid') with Dact assms show ?thesis by (cases "(uid,uid') â {(UID1,UID2), (UID2,UID1)}") (auto simp: d_defs eqButUID_def eqButUIDf_not_UID') qed next case (Cact ca) then show ?thesis using assms proof (cases ca) case (cFriend uid p uid') with Cact assms show ?thesis by (cases "(uid,uid') â {(UID1,UID2), (UID2,UID1)}") (auto simp: c_defs eqButUID_def eqButUIDf_not_UID') qed (auto simp: c_defs) qed auto lemma eqButUID_step_Ï_imp: assumes ss1: "eqButUID s s1" and rs: "reach s" and rs1: "reach s1" and step: "step s a = (ou,s')" and step1: "step s1 a = (ou1,s1')" and a: "a â Cact (cFriend UID1 (pass s UID1) UID2) â§ a â Cact (cFriend UID2 (pass s UID2) UID1) â§ a â Dact (dFriend UID1 (pass s UID1) UID2) â§ a â Dact (dFriend UID2 (pass s UID2) UID1)" and Ï: "Ï (Trans s a ou s')" shows "Ï (Trans s1 a ou1 s1')" proof - have "eqButUID s' s1'" using eqButUID_step[OF ss1 step step1 rs rs1] . then have "open s = open s1" and "open s' = open s1'" and "openByA s = openByA s1" and "openByA s' = openByA s1'" and "openByF s = openByF s1" and "openByF s' = openByF s1'" using ss1 by (auto simp: eqButUID_open_eq eqButUID_openByA_eq eqButUID_openByF_eq) with Ï a step step1 show "Ï (Trans s1 a ou1 s1')" using UID1_UID2_UIDs by (elim Ï.elims) (auto simp: c_defs d_defs) qed (* Key lemma: *) lemma eqButUID_step_Ï: assumes ss1: "eqButUID s s1" and rs: "reach s" and rs1: "reach s1" and step: "step s a = (ou,s')" and step1: "step s1 a = (ou1,s1')" and a: "a â Cact (cFriend UID1 (pass s UID1) UID2) â§ a â Cact (cFriend UID2 (pass s UID2) UID1) â§ a â Dact (dFriend UID1 (pass s UID1) UID2) â§ a â Dact (dFriend UID2 (pass s UID2) UID1)" shows "Ï (Trans s a ou s') = Ï (Trans s1 a ou1 s1')" proof assume "Ï (Trans s a ou s')" with assms show "Ï (Trans s1 a ou1 s1')" by (rule eqButUID_step_Ï_imp) next assume "Ï (Trans s1 a ou1 s1')" moreover have "eqButUID s1 s" using ss1 by (rule eqButUID_sym) moreover have "a â Cact (cFriend UID1 (pass s1 UID1) UID2) â§ a â Cact (cFriend UID2 (pass s1 UID2) UID1) â§ a â Dact (dFriend UID1 (pass s1 UID1) UID2) â§ a â Dact (dFriend UID2 (pass s1 UID2) UID1)" using a ss1 unfolding eqButUID_def by auto ultimately show "Ï (Trans s a ou s')" using rs rs1 step step1 by (intro eqButUID_step_Ï_imp[of s1 s]) qed lemma createFriend_sym: "createFriend s uid p uid' = createFriend s uid' p' uid" unfolding c_defs by (cases "uid = uid'") (auto simp: fun_upd2_comm fun_upd_twist) lemma deleteFriend_sym: "deleteFriend s uid p uid' = deleteFriend s uid' p' uid" unfolding d_defs by (cases "uid = uid'") (auto simp: fun_upd_twist) lemma createFriendReq_createFriend_absorb: assumes "e_createFriendReq s uid' p uid req" shows "createFriend (createFriendReq s uid' p1 uid req) uid p2 uid' = createFriend s uid p3 uid'" using assms unfolding c_defs by (auto simp: remove1_idem remove1_append fun_upd2_absorb) lemma eqButUID_deleteFriend12_friendIDs_eq: assumes ss1: "eqButUID s s1" and rs: "reach s" and rs1: "reach s1" shows "friendIDs (deleteFriend s UID1 p UID2) = friendIDs (deleteFriend s1 UID1 p' UID2)" proof - have "distinct (friendIDs s UID1)" "distinct (friendIDs s UID2)" "distinct (friendIDs s1 UID1)" "distinct (friendIDs s1 UID2)" using rs rs1 by (auto intro: reach_distinct_friends_reqs) then show ?thesis using ss1 unfolding eqButUID_def eqButUIDf_def unfolding d_defs by (auto simp: distinct_remove1_removeAll) qed lemma eqButUID_createFriend12_friendIDs_eq: assumes ss1: "eqButUID s s1" and rs: "reach s" and rs1: "reach s1" and f12: "Â¬friends12 s" "Â¬friends12 s1" shows "friendIDs (createFriend s UID1 p UID2) = friendIDs (createFriend s1 UID1 p' UID2)" proof - have f12': "UID1 â set (friendIDs s UID2)" "UID2 â set (friendIDs s UID1)" "UID1 â set (friendIDs s1 UID2)" "UID2 â set (friendIDs s1 UID1)" using f12 rs rs1 reach_friendIDs_symmetric unfolding friends12_def by auto have "friendIDs s = friendIDs s1" proof (intro ext) fix uid show "friendIDs s uid = friendIDs s1 uid" using ss1 f12' unfolding eqButUID_def eqButUIDf_def by (cases "uid = UID1 â¨ uid = UID2") (auto simp: remove1_idem) qed then show ?thesis by (auto simp: c_defs) qed end

theory Friend imports "../Observation_Setup" Friend_Value_Setup begin subsection â¹Declassification boundâº fun T :: "(state,act,out) trans â bool" where "T (Trans _ _ _ _) = False" text â¹The bound follows the same ``while-or-last-before'' scheme as the bound for post confidentiality (Section~\ref{sec:post-bound}), alternating between open (â¹BOâº) and closed (â¹BCâº) phases. The access window is initially open, because the two users are known not to exist when the system is initialized, so there cannot be friendship between them. The bound also incorporates the static knowledge that the friendship status alternates between â¹Falseâº and â¹Trueâº.âº fun alternatingFriends :: "value list â bool â bool" where "alternatingFriends [] _ = True" | "alternatingFriends (FrVal st # vl) st' â· st' = (Â¬st) â§ alternatingFriends vl st" | "alternatingFriends (OVal _ # vl) st = alternatingFriends vl st" inductive BO :: "value list â value list â bool" and BC :: "value list â value list â bool" where BO_FrVal[simp,intro!]: "BO (map FrVal fs) (map FrVal fs)" |BO_BC[intro]: "BC vl vl1 â¹ BO (map FrVal fs @ OVal False # vl) (map FrVal fs @ OVal False # vl1)" (* *) |BC_FrVal[simp,intro!]: "BC (map FrVal fs) (map FrVal fs1)" |BC_BO[intro]: "BO vl vl1 â¹ (fs = [] â· fs1 = []) â¹ (fs â [] â¹ last fs = last fs1) â¹ BC (map FrVal fs @ OVal True # vl) (map FrVal fs1 @ OVal True # vl1)" definition "B vl vl1 â¡ BO vl vl1 â§ alternatingFriends vl1 False" lemma BO_Nil_Nil: "BO vl vl1 â¹ vl = [] â¹ vl1 = []" by (cases rule: BO.cases) auto no_notation relcomp (infixr "O" 75) interpretation BD_Security_IO where istate = istate and step = step and Ï = Ï and f = f and Î³ = Î³ and g = g and T = T and B = B done subsection â¹Unwinding proofâº (* Key lemma: *) lemma eqButUID_step_Î³_out: assumes ss1: "eqButUID s s1" and step: "step s a = (ou,s')" and step1: "step s1 a = (ou1,s1')" and Î³: "Î³ (Trans s a ou s')" and os: "open s â¶ friendIDs s = friendIDs s1" shows "ou = ou1" proof - from Î³ obtain uid where uid: "userOfA a = Some uid â§ uid â UIDs â§ uid â UID1 â§ uid â UID2 â¨ userOfA a = None" using UID1_UID2_UIDs by (cases "userOfA a") auto { fix uid assume "uid ââ friendIDs s UID1 â¨ uid ââ friendIDs s UID2" and "uid â UIDs" with os have "friendIDs s = friendIDs s1" unfolding open_def openByF_def by auto } note fIDs = this { fix uid uid' assume uid: "uid â UID1" "uid â UID2" have "friendIDs s uid = friendIDs s1 uid" (is ?f_eq) and "pendingFReqs s uid = pendingFReqs s1 uid" (is ?pFR_eq) and "uid ââ friendIDs s uid' â· uid ââ friendIDs s1 uid'" (is ?f_iff) and "uid ââ pendingFReqs s uid' â· uid ââ pendingFReqs s1 uid'" (is ?pFR_iff) and "friendReq s uid uid' = friendReq s1 uid uid'" (is ?FR_eq) and "friendReq s uid' uid = friendReq s1 uid' uid" (is ?FR_eq') proof - show ?f_eq ?pFR_eq using uid ss1 UID1_UID2_UIDs unfolding eqButUID_def by (auto intro!: eqButUIDf_not_UID) show ?f_iff ?pFR_iff using uid ss1 UID1_UID2_UIDs unfolding eqButUID_def by (auto intro!: eqButUIDf_not_UID') from uid have "Â¬ (uid,uid') â {(UID1,UID2), (UID2,UID1)}" by auto then show ?FR_eq ?FR_eq' using ss1 UID1_UID2_UIDs unfolding eqButUID_def by (auto intro!: eqButUID12_not_UID) qed } note simps = this eqButUID_def r_defs s_defs c_defs l_defs u_defs d_defs note facts = ss1 step step1 uid show ?thesis proof (cases a) case (Ract ra) then show ?thesis using facts by (cases ra) (auto simp add: simps) next case (Sact sa) then show ?thesis using facts by (cases sa) (auto simp add: simps) next case (Cact ca) then show ?thesis using facts by (cases ca) (auto simp add: simps) next case (Lact la) then show ?thesis using facts proof (cases la) case (lFriends uid p uid') with Î³ have uid: "uid â UIDs" using Lact by auto then have uid_uid': "uid ââ friendIDs s uid' â· uid ââ friendIDs s1 uid'" using ss1 UID1_UID2_UIDs unfolding eqButUID_def by (intro eqButUIDf_not_UID') auto show ?thesis proof (cases "(uid' = UID1 â¨ uid' = UID2) â§ uid ââ friendIDs s uid'") case True with uid have "friendIDs s = friendIDs s1" by (intro fIDs) auto then show ?thesis using lFriends facts Lact by (auto simp: simps) next case False then show ?thesis using lFriends facts Lact simps(1) uid_uid' by (auto simp: simps) qed next case (lPosts uid p) then have o: "âPID. owner s PID = owner s1 PID" and n: "âPID. post s PID = post s1 PID" and PIDs: "postIDs s = postIDs s1" and viss: "vis s = vis s1" and fu: "âuid'. uid ââ friendIDs s uid' â· uid ââ friendIDs s1 uid'" and e: "e_listPosts s uid p â· e_listPosts s1 uid p" using ss1 uid Lact unfolding eqButUID_def l_defs by (auto simp add: simps(3)) have "listPosts s uid p = listPosts s1 uid p" unfolding listPosts_def o n PIDs fu viss .. with e show ?thesis using Lact lPosts step step1 by auto qed (auto simp add: simps) next case (Uact ua) then show ?thesis using facts by (cases ua) (auto simp add: simps) next case (Dact da) then show ?thesis using facts by (cases da) (auto simp add: simps) qed qed (* helper *) lemma toggle_friends12_True: assumes rs: "reach s" and IDs: "IDsOK s [UID1, UID2] []" and nf12: "Â¬friends12 s" obtains al oul where "sstep s al = (oul, createFriend s UID1 (pass s UID1) UID2)" and "al â []" and "eqButUID s (createFriend s UID1 (pass s UID1) UID2)" and "friends12 (createFriend s UID1 (pass s UID1) UID2)" and "O (traceOf s al) = []" and "V (traceOf s al) = [FrVal True]" proof cases assume "UID1 ââ pendingFReqs s UID2 â¨ UID2 ââ pendingFReqs s UID1" then show thesis proof assume pFR: "UID1 ââ pendingFReqs s UID2" let ?a = "Cact (cFriend UID2 (pass s UID2) UID1)" let ?s' = "createFriend s UID1 (pass s UID1) UID2" let ?trn = "Trans s ?a outOK ?s'" have step: "step s ?a = (outOK, ?s')" using IDs pFR UID1_UID2 unfolding createFriend_sym[of "s" "UID1" "pass s UID1" "UID2" "pass s UID2"] by (auto simp add: c_defs) moreover then have "Ï ?trn" and "f ?trn = FrVal True" and "friends12 ?s'" by (auto simp: c_defs friends12_def) moreover have "Â¬Î³ ?trn" using UID1_UID2_UIDs by auto ultimately show thesis using nf12 rs by (intro that[of "[?a]" "[outOK]"]) (auto intro: Cact_cFriend_step_eqButUID) next assume pFR: "UID2 ââ pendingFReqs s UID1" let ?a = "Cact (cFriend UID1 (pass s UID1) UID2)" let ?s' = "createFriend s UID1 (pass s UID1) UID2" let ?trn = "Trans s ?a outOK ?s'" have step: "step s ?a = (outOK, ?s')" using IDs pFR UID1_UID2 by (auto simp add: c_defs) moreover then have "Ï ?trn" and "f ?trn = FrVal True" and "friends12 ?s'" by (auto simp: c_defs friends12_def) moreover have "Â¬Î³ ?trn" using UID1_UID2_UIDs by auto ultimately show thesis using nf12 rs by (intro that[of "[?a]" "[outOK]"]) (auto intro: Cact_cFriend_step_eqButUID) qed next assume pFR: "Â¬(UID1 ââ pendingFReqs s UID2 â¨ UID2 ââ pendingFReqs s UID1)" let ?a1 = "Cact (cFriendReq UID2 (pass s UID2) UID1 emptyReq)" let ?s1 = "createFriendReq s UID2 (pass s UID2) UID1 emptyReq" let ?trn1 = "Trans s ?a1 outOK ?s1" let ?a2 = "Cact (cFriend UID1 (pass ?s1 UID1) UID2)" let ?s2 = "createFriend ?s1 UID1 (pass ?s1 UID1) UID2" let ?trn2 = "Trans ?s1 ?a2 outOK ?s2" have eFR: "e_createFriendReq s UID2 (pass s UID2) UID1 emptyReq" using IDs pFR nf12 using reach_friendIDs_symmetric[OF rs] by (auto simp add: c_defs friends12_def) then have step1: "step s ?a1 = (outOK, ?s1)" by auto moreover then have "Â¬Ï ?trn1" and "Â¬Î³ ?trn1" using UID1_UID2_UIDs by auto moreover have "eqButUID s ?s1" by (intro Cact_cFriendReq_step_eqButUID[OF step1]) auto moreover have rs1: "reach ?s1" using step1 by (intro reach_PairI[OF rs]) moreover have step2: "step ?s1 ?a2 = (outOK, ?s2)" using IDs by (auto simp: c_defs) moreover then have "Ï ?trn2" and "f ?trn2 = FrVal True" and "friends12 ?s2" by (auto simp: c_defs friends12_def) moreover have "Â¬Î³ ?trn2" using UID1_UID2_UIDs by auto moreover have "eqButUID ?s1 ?s2" by (intro Cact_cFriend_step_eqButUID[OF step2 rs1]) auto moreover have "?s2 = createFriend s UID1 (pass s UID1) UID2" using eFR by (intro createFriendReq_createFriend_absorb) ultimately show thesis using nf12 rs by (intro that[of "[?a1, ?a2]" "[outOK, outOK]"]) (auto intro: eqButUID_trans) qed (* helper *) lemma toggle_friends12_False: assumes rs: "reach s" and IDs: "IDsOK s [UID1, UID2] []" and f12: "friends12 s" obtains al oul where "sstep s al = (oul, deleteFriend s UID1 (pass s UID1) UID2)" and "al â []" and "eqButUID s (deleteFriend s UID1 (pass s UID1) UID2)" and "Â¬friends12 (deleteFriend s UID1 (pass s UID1) UID2)" and "O (traceOf s al) = []" and "V (traceOf s al) = [FrVal False]" proof - let ?a = "Dact (dFriend UID1 (pass s UID1) UID2)" let ?s' = "deleteFriend s UID1 (pass s UID1) UID2" let ?trn = "Trans s ?a outOK ?s'" have step: "step s ?a = (outOK, ?s')" using IDs f12 UID1_UID2 by (auto simp add: d_defs friends12_def) moreover then have "Ï ?trn" and "f ?trn = FrVal False" and "Â¬friends12 ?s'" using reach_friendIDs_symmetric[OF rs] by (auto simp: d_defs friends12_def) moreover have "Â¬Î³ ?trn" using UID1_UID2_UIDs by auto ultimately show thesis using f12 rs by (intro that[of "[?a]" "[outOK]"]) (auto intro: Dact_dFriend_step_eqButUID) qed definition Î0 :: "state â value list â state â value list â bool" where "Î0 s vl s1 vl1 â¡ eqButUID s s1 â§ friendIDs s = friendIDs s1 â§ open s â§ BO vl vl1 â§ alternatingFriends vl1 (friends12 s1)" definition Î1 :: "state â value list â state â value list â bool" where "Î1 s vl s1 vl1 â¡ (âfs fs1. eqButUID s s1 â§ Â¬open s â§ alternatingFriends vl1 (friends12 s1) â§ vl = map FrVal fs â§ vl1 = map FrVal fs1)" definition Î2 :: "state â value list â state â value list â bool" where "Î2 s vl s1 vl1 â¡ (âfs fs1 vlr vlr1. eqButUID s s1 â§ Â¬open s â§ BO vlr vlr1 â§ alternatingFriends vl1 (friends12 s1) â§ (fs = [] â· fs1 = []) â§ (fs â [] â¶ last fs = last fs1) â§ (fs = [] â¶ friendIDs s = friendIDs s1) â§ vl = map FrVal fs @ OVal True # vlr â§ vl1 = map FrVal fs1 @ OVal True # vlr1)" lemma Î2_I: assumes "eqButUID s s1" "Â¬open s" "BO vlr vlr1" "alternatingFriends vl1 (friends12 s1)" "fs = [] â· fs1 = []" "fs â [] â¶ last fs = last fs1" "fs = [] â¶ friendIDs s = friendIDs s1" "vl = map FrVal fs @ OVal True # vlr" "vl1 = map FrVal fs1 @ OVal True # vlr1" shows "Î2 s vl s1 vl1" using assms unfolding Î2_def by blast lemma istate_Î0: assumes B: "B vl vl1" shows "Î0 istate vl istate vl1" using assms unfolding Î0_def istate_def B_def open_def openByA_def openByF_def friends12_def by auto lemma unwind_cont_Î0: "unwind_cont Î0 {Î0,Î1,Î2}" proof(rule, simp) let ?Î = "Î»s vl s1 vl1. Î0 s vl s1 vl1 â¨ Î1 s vl s1 vl1 â¨ Î2 s vl s1 vl1" fix s s1 :: state and vl vl1 :: "value list" assume rsT: "reachNT s" and rs1: "reach s1" and Î0: "Î0 s vl s1 vl1" then have rs: "reach s" and ss1: "eqButUID s s1" and fIDs: "friendIDs s = friendIDs s1" and os: "open s" and BO: "BO vl vl1" and aF1: "alternatingFriends vl1 (friends12 s1)" using reachNT_reach unfolding Î0_def by auto show "iaction ?Î s vl s1 vl1 â¨ ((vl = [] â¶ vl1 = []) â§ reaction ?Î s vl s1 vl1)" (is "?iact â¨ (_ â§ ?react)") proof- have ?react proof fix a :: act and ou :: out and s' :: state and vl' let ?trn = "Trans s a ou s'" assume step: "step s a = (ou, s')" and T: "Â¬ T ?trn" and c: "consume ?trn vl vl'" show "match ?Î s s1 vl1 a ou s' vl' â¨ ignore ?Î s s1 vl1 a ou s' vl'" (is "?match â¨ ?ignore") proof cases assume Ï: "Ï ?trn" then have vl: "vl = f ?trn # vl'" using c by (auto simp: consume_def) from BO have ?match proof (cases "f ?trn") case (FrVal fv) with BO vl obtain vl1' where vl1': "vl1 = f ?trn # vl1'" and BO': "BO vl' vl1'" proof (cases rule: BO.cases) case (BO_BC vl'' vl1'' fs) moreover with vl FrVal obtain fs' where "fs = fv # fs'" by (cases fs) auto ultimately show ?thesis using FrVal BO_BC vl by (intro that[of "map FrVal fs' @ OVal False # vl1''"]) auto qed auto from fIDs have f12: "friends12 s = friends12 s1" unfolding friends12_def by auto show ?match using Ï step rs FrVal proof (cases rule: ÏE) case (Friend uid p uid') then have IDs1: "IDsOK s1 [UID1, UID2] []" using ss1 unfolding eqButUID_def by auto let ?s1' = "createFriend s1 UID1 (pass s1 UID1) UID2" have s': "s' = createFriend s UID1 p UID2" using Friend step by (auto simp: createFriend_sym) have ss': "eqButUID s s'" using rs step Friend by (auto intro: Cact_cFriend_step_eqButUID) moreover then have os': "open s'" using os eqButUID_open_eq by auto moreover obtain al oul where al: "sstep s1 al = (oul, ?s1')" "al â []" and tr1: "O (traceOf s1 al) = []" "V (traceOf s1 al) = [FrVal True]" and f12s1': "friends12 ?s1'" and s1s1': "eqButUID s1 ?s1'" using rs1 IDs1 Friend unfolding f12 by (auto elim: toggle_friends12_True) moreover have "friendIDs s' = friendIDs ?s1'" using Friend(6) f12 unfolding s' by (intro eqButUID_createFriend12_friendIDs_eq[OF ss1 rs rs1]) auto ultimately have "Î0 s' vl' ?s1' vl1'" using ss1 BO' aF1 unfolding Î0_def vl1' Friend(3) by (auto intro: eqButUID_trans eqButUID_sym) moreover have "Â¬Î³ ?trn" using Friend UID1_UID2_UIDs by auto ultimately show ?match using tr1 vl1' Friend by (intro matchI_ms[OF al]) (auto simp: consumeList_def) next case (Unfriend uid p uid') then have IDs1: "IDsOK s1 [UID1, UID2] []" using ss1 unfolding eqButUID_def by auto let ?s1' = "deleteFriend s1 UID1 (pass s1 UID1) UID2" have s': "s' = deleteFriend s UID1 p UID2" using Unfriend step by (auto simp: deleteFriend_sym) have ss': "eqButUID s s'" using rs step Unfriend by (auto intro: Dact_dFriend_step_eqButUID) moreover then have os': "open s'" using os eqButUID_open_eq by auto moreover obtain al oul where al: "sstep s1 al = (oul, ?s1')" "al â []" and tr1: "O (traceOf s1 al) = []" "V (traceOf s1 al) = [FrVal False]" and f12s1': "Â¬friends12 ?s1'" and s1s1': "eqButUID s1 ?s1'" using rs1 IDs1 Unfriend unfolding f12 by (auto elim: toggle_friends12_False) moreover have "friendIDs s' = friendIDs ?s1'" using fIDs unfolding s' by (auto simp: d_defs) ultimately have "Î0 s' vl' ?s1' vl1'" using ss1 BO' aF1 unfolding Î0_def vl1' Unfriend(3) by (auto intro: eqButUID_trans eqButUID_sym) moreover have "Â¬Î³ ?trn" using Unfriend UID1_UID2_UIDs by auto ultimately show ?match using tr1 vl1' Unfriend by (intro matchI_ms[OF al]) (auto simp: consumeList_def) qed auto next case (OVal ov) with BO vl obtain vl1' where vl1': "vl1 = OVal False # vl1'" and vl': "vl = OVal False # vl'" and BC: "BC vl' vl1'" proof (cases rule: BO.cases) case (BO_BC vl'' vl1'' fs) moreover then have "fs = []" using vl unfolding OVal by (cases fs) auto ultimately show thesis using vl by (intro that[of vl1'']) auto qed auto then have "f ?trn = OVal False" using vl by auto with Ï step rs show ?match proof (cases rule: ÏE) case (CloseF uid p uid') let ?s1' = "deleteFriend s1 uid p uid'" let ?trn1 = "Trans s1 a outOK ?s1'" have s': "s' = deleteFriend s uid p uid'" using CloseF step by auto have step1: "step s1 a = (outOK, ?s1')" using CloseF step ss1 fIDs unfolding eqButUID_def by (auto simp: d_defs) have s's1': "eqButUID s' ?s1'" using eqButUID_step[OF ss1 step step1 rs rs1] . moreover have os': "Â¬open s'" using CloseF os unfolding open_def by auto moreover have fIDs': "friendIDs s' = friendIDs ?s1'" using fIDs unfolding s' by (auto simp: d_defs) moreover have f12s1: "friends12 s1 = friends12 ?s1'" using CloseF(2) UID1_UID2_UIDs unfolding friends12_def d_defs by auto from BC have "Î1 s' vl' ?s1' vl1' â¨ Î2 s' vl' ?s1' vl1'" proof (cases rule: BC.cases) case (BC_FrVal fs fs1) then show ?thesis using aF1 os' fIDs' f12s1 s's1' unfolding Î1_def vl1' by auto next case (BC_BO vlr vlr1 fs fs1) then have "Î2 s' vl' ?s1' vl1'" using s's1' os' aF1 f12s1 fIDs' unfolding vl1' by (intro Î2_I[of _ _ _ _ _ fs fs1]) auto then show ?thesis .. qed moreover have "open s1" "Â¬open ?s1'" using ss1 os s's1' os' by (auto simp: eqButUID_open_eq) moreover then have "Ï ?trn1" unfolding CloseF by auto ultimately show ?match using step1 vl1' CloseF UID1_UID2 UID1_UID2_UIDs by (intro matchI[of s1 a outOK ?s1' vl1 vl1']) (auto simp: consume_def) next case (CloseA uid p uid' p') let ?s1' = "createUser s1 uid p uid' p'" let ?trn1 = "Trans s1 a outOK ?s1'" have s': "s' = createUser s uid p uid' p'" using CloseA step by auto have step1: "step s1 a = (outOK, ?s1')" using CloseA step ss1 unfolding eqButUID_def by (auto simp: c_defs) have s's1': "eqButUID s' ?s1'" using eqButUID_step[OF ss1 step step1 rs rs1] . moreover have os': "Â¬open s'" using CloseA os unfolding open_def by auto moreover have fIDs': "friendIDs s' = friendIDs ?s1'" using fIDs unfolding s' by (auto simp: c_defs) moreover have f12s1: "friends12 s1 = friends12 ?s1'" unfolding friends12_def by (auto simp: c_defs) from BC have "Î1 s' vl' ?s1' vl1' â¨ Î2 s' vl' ?s1' vl1'" proof (cases rule: BC.cases) case (BC_FrVal fs fs1) then show ?thesis using aF1 os' fIDs' f12s1 s's1' unfolding Î1_def vl1' by auto next case (BC_BO vlr vlr1 fs fs1) then have "Î2 s' vl' ?s1' vl1'" using s's1' os' aF1 f12s1 fIDs' unfolding vl1' by (intro Î2_I[of _ _ _ _ _ fs fs1]) auto then show ?thesis .. qed moreover have "open s1" "Â¬open ?s1'" using ss1 os s's1' os' by (auto simp: eqButUID_open_eq) moreover then have "Ï ?trn1" unfolding CloseA by auto ultimately show ?match using step1 vl1' CloseA UID1_UID2 UID1_UID2_UIDs by (intro matchI[of s1 a outOK ?s1' vl1 vl1']) (auto simp: consume_def) qed auto qed then show "?match â¨ ?ignore" .. next assume nÏ: "Â¬Ï ?trn" then have os': "open s = open s'" and f12s': "friends12 s = friends12 s'" using step_open_Ï[OF step] step_friends12_Ï[OF step] by auto have vl': "vl' = vl" using nÏ c by (auto simp: consume_def) show ?thesis proof (cases "a â Cact (cFriend UID1 (pass s UID1) UID2) â§ a â Cact (cFriend UID2 (pass s UID2) UID1) â§ a â Dact (dFriend UID1 (pass s UID1) UID2) â§ a â Dact (dFriend UID2 (pass s UID2) UID1)") case True obtain ou1 s1' where step1: "step s1 a = (ou1, s1')" by (cases "step s1 a") auto let ?trn1 = "Trans s1 a ou1 s1'" have fIDs': "friendIDs s' = friendIDs s1'" using eqButUID_step_friendIDs_eq[OF ss1 rs rs1 step step1 True fIDs] . from True nÏ have nÏ': "Â¬Ï ?trn1" using eqButUID_step_Ï[OF ss1 rs rs1 step step1] by auto then have f12s1': "friends12 s1 = friends12 s1'" using step_friends12_Ï[OF step1] by auto have "eqButUID s' s1'" using eqButUID_step[OF ss1 step step1 rs rs1] . then have "Î0 s' vl' s1' vl1" using os fIDs' aF1 BO unfolding Î0_def os' f12s1' vl' by auto then have ?match using step1 nÏ' fIDs eqButUID_step_Î³_out[OF ss1 step step1] by (intro matchI[of s1 a ou1 s1' vl1 vl1]) (auto simp: consume_def) then show "?match â¨ ?ignore" .. next case False with nÏ have "ou â outOK" by auto then have "s' = s" using step False by auto then have ?ignore using Î0 False UID1_UID2_UIDs unfolding vl' by (intro ignoreI) auto then show "?match â¨ ?ignore" .. qed qed qed then show ?thesis using BO BO_Nil_Nil by auto qed qed lemma unwind_cont_Î1: "unwind_cont Î1 {Î1, Î0}" proof(rule, simp) let ?Î = "Î»s vl s1 vl1. Î1 s vl s1 vl1 â¨ Î0 s vl s1 vl1" fix s s1 :: state and vl vl1 :: "value list" assume rsT: "reachNT s" and rs1: "reach s1" and 1: "Î1 s vl s1 vl1" from rsT have rs: "reach s" by (intro reachNT_reach) from 1 obtain fs fs1 where ss1: "eqButUID s s1" and os: "Â¬open s" and aF1: "alternatingFriends vl1 (friends12 s1)" and vl: "vl = map FrVal fs" and vl1: "vl1 = map FrVal fs1" unfolding Î1_def by auto from os have IDs: "IDsOK s [UID1, UID2] []" unfolding open_defs by auto then have IDs1: "IDsOK s1 [UID1, UID2] []" using ss1 unfolding eqButUID_def by auto show "iaction ?Î s vl s1 vl1 â¨ ((vl = [] â¶ vl1 = []) â§ reaction ?Î s vl s1 vl1)" (is "?iact â¨ (_ â§ ?react)") proof cases assume fs1: "fs1 = []" have ?react proof fix a :: act and ou :: out and s' :: state and vl' let ?trn = "Trans s a ou s'" assume step: "step s a = (ou, s')" and T: "Â¬ T ?trn" and c: "consume ?trn vl vl'" show "match ?Î s s1 vl1 a ou s' vl' â¨ ignore ?Î s s1 vl1 a ou s' vl'" (is "?match â¨ ?ignore") proof cases assume Ï: "Ï ?trn" with vl c obtain fv fs' where vl': "vl' = map FrVal fs'" and fv: "f ?trn = FrVal fv" by (cases fs) (auto simp: consume_def) from Ï step rs fv have ss': "eqButUID s s'" by (elim ÏE) (auto intro: Cact_cFriend_step_eqButUID Dact_dFriend_step_eqButUID) then have "Â¬open s'" using os by (auto simp: eqButUID_open_eq) moreover have "eqButUID s' s1" using ss1 ss' by (auto intro: eqButUID_sym eqButUID_trans) ultimately have "Î1 s' vl' s1 vl1" using aF1 unfolding Î1_def vl' vl1 by auto moreover have "Â¬Î³ ?trn" using Ï step rs fv UID1_UID2_UIDs by (elim ÏE) auto ultimately have ?ignore by (intro ignoreI) auto then show "?match â¨ ?ignore" .. next assume nÏ: "Â¬Ï ?trn" then have os': "open s = open s'" and f12s': "friends12 s = friends12 s'" using step_open_Ï[OF step] step_friends12_Ï[OF step] by auto have vl': "vl' = vl" using nÏ c by (auto simp: consume_def) show ?thesis proof (cases "a â Cact (cFriend UID1 (pass s UID1) UID2) â§ a â Cact (cFriend UID2 (pass s UID2) UID1) â§ a â Dact (dFriend UID1 (pass s UID1) UID2) â§ a â Dact (dFriend UID2 (pass s UID2) UID1)") case True obtain ou1 s1' where step1: "step s1 a = (ou1, s1')" by (cases "step s1 a") auto let ?trn1 = "Trans s1 a ou1 s1'" from True nÏ have nÏ': "Â¬Ï ?trn1" using eqButUID_step_Ï[OF ss1 rs rs1 step step1] by auto then have f12s1': "friends12 s1 = friends12 s1'" using step_friends12_Ï[OF step1] by auto have "eqButUID s' s1'" using eqButUID_step[OF ss1 step step1 rs rs1] . then have "Î1 s' vl' s1' vl1" using os aF1 vl vl1 unfolding Î1_def os' vl' f12s1' by auto then have ?match using step1 nÏ' os eqButUID_step_Î³_out[OF ss1 step step1] by (intro matchI[of s1 a ou1 s1' vl1 vl1]) (auto simp: consume_def) then show "?match â¨ ?ignore" .. next case False with nÏ have "ou â outOK" by auto then have "s' = s" using step False by auto then have ?ignore using 1 False UID1_UID2_UIDs unfolding vl' by (intro ignoreI) auto then show "?match â¨ ?ignore" .. qed qed qed then show ?thesis using fs1 unfolding vl1 by auto next assume "fs1 â []" then obtain fs1' where fs1: "fs1 = (Â¬friends12 s1) # fs1'" and aF1': "alternatingFriends (map FrVal fs1') (Â¬friends12 s1)" using aF1 unfolding vl1 by (cases fs1) auto obtain al oul s1' where "sstep s1 al = (oul, s1')" "al â []" "eqButUID s1 s1'" "friends12 s1' = (Â¬friends12 s1)" "O (traceOf s1 al) = []" "V (traceOf s1 al) = [FrVal (Â¬friends12 s1)]" using rs1 IDs1 by (cases "friends12 s1") (auto intro: toggle_friends12_True toggle_friends12_False) moreover then have "Î1 s vl s1' (map FrVal fs1')" using os aF1' vl ss1 unfolding Î1_def by (auto intro: eqButUID_sym eqButUID_trans) ultimately have ?iact using vl1 unfolding fs1 by (intro iactionI_ms[of s1 al oul s1']) (auto simp: consumeList_def O_Nil_never list_ex_iff_length_V) then show ?thesis .. qed qed lemma unwind_cont_Î2: "unwind_cont Î2 {Î2,Î0}" proof(rule, simp) let ?Î = "Î»s vl s1 vl1. Î2 s vl s1 vl1 â¨ Î0 s vl s1 vl1" fix s s1 :: state and vl vl1 :: "value list" assume rsT: "reachNT s" and rs1: "reach s1" and 2: "Î2 s vl s1 vl1" from rsT have rs: "reach s" by (intro reachNT_reach) obtain fs fs1 vlr vlr1 where ss1: "eqButUID s s1" and os: "Â¬open s" and BO: "BO vlr vlr1" and aF1: "alternatingFriends vl1 (friends12 s1)" and vl: "vl = map FrVal fs @ OVal True # vlr" and vl1: "vl1 = map FrVal fs1 @ OVal True # vlr1" and fs_fs1: "fs = [] â· fs1 = []" and last_fs: "fs â [] â¶ last fs = last fs1" and fs_fIDs: "fs = [] â¶ friendIDs s = friendIDs s1" using 2 unfolding Î2_def by auto from os have IDs: "IDsOK s [UID1, UID2] []" unfolding open_defs by auto then have IDs1: "IDsOK s1 [UID1, UID2] []" using ss1 unfolding eqButUID_def by auto show "iaction ?Î s vl s1 vl1 â¨ ((vl = [] â¶ vl1 = []) â§ reaction ?Î s vl s1 vl1)" (is "?iact â¨ (_ â§ ?react)") proof cases assume "length fs1 > 1" then obtain fs1' where fs1: "fs1 = (Â¬friends12 s1) # fs1'" and fs1': "fs1' â []" and last_fs': "last fs1 = last fs1'" and aF1': "alternatingFriends (map FrVal fs1' @ OVal True # vlr1) (Â¬friends12 s1)" using vl1 aF1 by (cases fs1) auto obtain al oul s1' where "sstep s1 al = (oul, s1')" "al â []" "eqButUID s1 s1'" "friends12 s1' = (Â¬friends12 s1)" "O (traceOf s1 al) = []" "V (traceOf s1 al) = [FrVal (Â¬friends12 s1)]" using rs1 IDs1 by (cases "friends12 s1") (auto intro: toggle_friends12_True toggle_friends12_False) moreover then have "Î2 s vl s1' (map FrVal fs1' @ OVal True # vlr1)" using os aF1' vl ss1 fs1' last_fs' fs_fs1 last_fs BO unfolding fs1 by (intro Î2_I[of _ _ vlr vlr1 _ fs fs1']) (auto intro: eqButUID_sym eqButUID_trans) ultimately have ?iact using vl1 unfolding fs1 by (intro iactionI_ms[of s1 al oul s1']) (auto simp: consumeList_def O_Nil_never list_ex_iff_length_V) then show ?thesis .. next assume len1_leq_1: "Â¬ length fs1 > 1" have ?react proof fix a :: act and ou :: out and s' :: state and vl' let ?trn = "Trans s a ou s'" let ?trn1 = "Trans s1 a ou s'" assume step: "step s a = (ou, s')" and T: "Â¬ T ?trn" and c: "consume ?trn vl vl'" show "match ?Î s s1 vl1 a ou s' vl' â¨ ignore ?Î s s1 vl1 a ou s' vl'" (is "?match â¨ ?ignore") proof cases assume Ï: "Ï ?trn" show ?thesis proof cases assume "length fs > 1" then obtain fv fs' where fs1: "fs = fv # fs'" and fs1': "fs' â []" and last_fs': "last fs = last fs'" using vl by (cases fs) auto with Ï c have fv: "f ?trn = FrVal fv" and vl': "vl' = map FrVal fs' @ OVal True # vlr" unfolding vl consume_def by auto from Ï step rs fv have ss': "eqButUID s s'" by (elim ÏE) (auto intro: Cact_cFriend_step_eqButUID Dact_dFriend_step_eqButUID) then have "Â¬open s'" using os by (auto simp: eqButUID_open_eq) moreover have "eqButUID s' s1" using ss1 ss' by (auto intro: eqButUID_sym eqButUID_trans) ultimately have "Î2 s' vl' s1 vl1" using aF1 vl' fs1' fs_fs1 last_fs BO unfolding fs1 vl1 by (intro Î2_I[of _ _ vlr vlr1 _ fs' fs1]) (auto intro: eqButUID_sym eqButUID_trans) moreover have "Â¬Î³ ?trn" using Ï step rs fv UID1_UID2_UIDs by (elim ÏE) auto ultimately have ?ignore by (intro ignoreI) auto then show "?match â¨ ?ignore" .. next assume len_leq_1: "Â¬ length fs > 1" show ?thesis proof cases assume fs: "fs = []" then have fs1: "fs1 = []" and fIDs: "friendIDs s = friendIDs s1" using fs_fs1 fs_fIDs by auto from fs Ï c have ov: "f ?trn = OVal True" and vl': "vl' = vlr" unfolding vl consume_def by auto with Ï step rs have ?match proof (cases rule: ÏE) case (OpenF uid p uid') let ?s1' = "createFriend s1 uid p uid'" let ?trn1 = "Trans s1 a outOK ?s1'" have s': "s' = createFriend s uid p uid'" using OpenF step by auto have "eqButUIDf (pendingFReqs s) (pendingFReqs s1)" using ss1 unfolding eqButUID_def by auto then have "uid' ââ pendingFReqs s uid â· uid' ââ pendingFReqs s1 uid" using OpenF by (intro eqButUIDf_not_UID') auto then have step1: "step s1 a = (outOK, ?s1')" using OpenF step ss1 fIDs unfolding eqButUID_def by (auto simp: c_defs) have s's1': "eqButUID s' ?s1'" using eqButUID_step[OF ss1 step step1 rs rs1] . moreover have os': "open s'" using OpenF unfolding open_def by auto moreover have fIDs': "friendIDs s' = friendIDs ?s1'" using fIDs unfolding s' by (auto simp: c_defs) moreover have f12s1: "friends12 s1 = friends12 ?s1'" using OpenF(2) UID1_UID2_UIDs unfolding friends12_def c_defs by auto ultimately have "Î0 s' vl' ?s1' vlr1" using BO aF1 unfolding Î0_def vl' vl1 fs1 by auto moreover have "Â¬open s1" "open ?s1'" using ss1 os s's1' os' by (auto simp: eqButUID_open_eq) moreover then have "Ï ?trn1" unfolding OpenF by auto ultimately show ?match using step1 vl1 fs1 OpenF UID1_UID2 UID1_UID2_UIDs by (intro matchI[of s1 a outOK ?s1' vl1 vlr1]) (auto simp: consume_def) qed auto then show ?thesis .. next assume "fs â []" then obtain fv where fs: "fs = [fv]" using len_leq_1 by (cases fs) auto then have fs1: "fs1 = [fv]" using len1_leq_1 fs_fs1 last_fs by (cases fs1) auto with aF1 have f12s1: "friends12 s1 = (Â¬fv)" unfolding vl1 by auto have fv: "f ?trn = FrVal fv" and vl': "vl' = OVal True # vlr" using c Ï unfolding vl fs by (auto simp: consume_def) with Ï step rs have ?match proof (cases rule: ÏE) case (Friend uid p uid') then have IDs1: "IDsOK s1 [UID1, UID2] []" using ss1 unfolding eqButUID_def by auto have fv: "fv = True" using fv Friend by auto let ?s1' = "createFriend s1 UID1 (pass s1 UID1) UID2" have s': "s' = createFriend s UID1 p UID2" using Friend step by (auto simp: createFriend_sym) have ss': "eqButUID s s'" using rs step Friend by (auto intro: Cact_cFriend_step_eqButUID) moreover then have os': "Â¬open s'" using os eqButUID_open_eq by auto moreover obtain al oul where al: "sstep s1 al = (oul, ?s1')" "al â []" and tr1: "O (traceOf s1 al) = []" "V (traceOf s1 al) = [FrVal True]" and f12s1': "friends12 ?s1'" and s1s1': "eqButUID s1 ?s1'" using rs1 IDs1 Friend f12s1 unfolding fv by (auto elim: toggle_friends12_True) moreover have "friendIDs s' = friendIDs ?s1'" using Friend(6) f12s1 unfolding s' fv by (intro eqButUID_createFriend12_friendIDs_eq[OF ss1 rs rs1]) auto ultimately have "Î2 s' vl' ?s1' (OVal True # vlr1)" using BO ss1 aF1 unfolding vl' vl1 fs1 f12s1 fv by (intro Î2_I[of _ _ _ _ _ "[]" "[]"]) (auto intro: eqButUID_trans eqButUID_sym) moreover have "Â¬Î³ ?trn" using Friend UID1_UID2_UIDs by auto ultimately show ?match using tr1 vl1 Friend unfolding fs1 fv by (intro matchI_ms[OF al]) (auto simp: consumeList_def) next case (Unfriend uid p uid') then have IDs1: "IDsOK s1 [UID1, UID2] []" using ss1 unfolding eqButUID_def by auto have fv: "fv = False" using fv Unfriend by auto let ?s1' = "deleteFriend s1 UID1 (pass s1 UID1) UID2" have s': "s' = deleteFriend s UID1 p UID2" using Unfriend step by (auto simp: deleteFriend_sym) have ss': "eqButUID s s'" using rs step Unfriend by (auto intro: Dact_dFriend_step_eqButUID) moreover then have os': "Â¬open s'" using os eqButUID_open_eq by auto moreover obtain al oul where al: "sstep s1 al = (oul, ?s1')" "al â []" and tr1: "O (traceOf s1 al) = []" "V (traceOf s1 al) = [FrVal False]" and f12s1': "Â¬friends12 ?s1'" and s1s1': "eqButUID s1 ?s1'" using rs1 IDs1 Unfriend f12s1 unfolding fv by (auto elim: toggle_friends12_False) moreover have "friendIDs s' = friendIDs ?s1'" using Unfriend(6) f12s1 unfolding s' fv by (intro eqButUID_deleteFriend12_friendIDs_eq[OF ss1 rs rs1]) ultimately have "Î2 s' vl' ?s1' (OVal True # vlr1)" using BO ss1 aF1 unfolding vl' vl1 fs1 f12s1 fv by (intro Î2_I[of _ _ _ _ _ "[]" "[]"]) (auto intro: eqButUID_trans eqButUID_sym) moreover have "Â¬Î³ ?trn" using Unfriend UID1_UID2_UIDs by auto ultimately show ?match using tr1 vl1 Unfriend unfolding fs1 fv by (intro matchI_ms[OF al]) (auto simp: consumeList_def) qed auto then show ?thesis .. qed qed next assume nÏ: "Â¬Ï ?trn" then have os': "open s = open s'" and f12s': "friends12 s = friends12 s'" using step_open_Ï[OF step] step_friends12_Ï[OF step] by auto have vl': "vl' = vl" using nÏ c by (auto simp: consume_def) show ?thesis proof (cases "a â Cact (cFriend UID1 (pass s UID1) UID2) â§ a â Cact (cFriend UID2 (pass s UID2) UID1) â§ a â Dact (dFriend UID1 (pass s UID1) UID2) â§ a â Dact (dFriend UID2 (pass s UID2) UID1)") case True obtain ou1 s1' where step1: "step s1 a = (ou1, s1')" by (cases "step s1 a") auto let ?trn1 = "Trans s1 a ou1 s1'" from True nÏ have nÏ': "Â¬Ï ?trn1" using eqButUID_step_Ï[OF ss1 rs rs1 step step1] by auto then have f12s1': "friends12 s1 = friends12 s1'" using step_friends12_Ï[OF step1] by auto have "eqButUID s' s1'" using eqButUID_step[OF ss1 step step1 rs rs1] . moreover have "friendIDs s = friendIDs s1 â¶ friendIDs s' = friendIDs s1'" using eqButUID_step_friendIDs_eq[OF ss1 rs rs1 step step1 True] .. ultimately have "Î2 s' vl' s1' vl1" using os' os aF1 BO fs_fs1 last_fs fs_fIDs unfolding f12s1' vl' vl vl1 by (intro Î2_I) auto then have ?match using step1 nÏ' os eqButUID_step_Î³_out[OF ss1 step step1] by (intro matchI[of s1 a ou1 s1' vl1 vl1]) (auto simp: consume_def) then show "?match â¨ ?ignore" .. next case False with nÏ have "ou â outOK" by auto then have "s' = s" using step False by auto then have ?ignore using 2 False UID1_UID2_UIDs unfolding vl' by (intro ignoreI) auto then show "?match â¨ ?ignore" .. qed qed qed then show ?thesis unfolding vl by auto qed qed definition Gr where "Gr = { (Î0, {Î0,Î1,Î2}), (Î1, {Î1,Î0}), (Î2, {Î2,Î0}) }" theorem secure: secure apply (rule unwind_decomp_secure_graph[of Gr Î0]) unfolding Gr_def apply (simp, smt insert_subset order_refl) using istate_Î0 unwind_cont_Î0 unwind_cont_Î1 unwind_cont_Î2 unfolding Gr_def by (auto intro: unwind_cont_mono) end

theory Friend_Request_Intro imports "../Safety_Properties" "../Observation_Setup" begin section â¹Friendship request confidentialityâº text â¹We prove the following property: \ \\ Given a group of users â¹UIDsâº and given two users â¹UID1âº and â¹UID2âº not in that group, that group cannot learn anything about the friendship requests issued between â¹UID1âº and â¹UID2âº beyond what everybody knows, namely that âª there is no friendship between â¹UID1âº and â¹UID2âº before those users have been created, and âª friendship status updates form an alternating sequence of friending and unfriending, every successful friend creation is preceded by at least one and at most two requests, and beyond those requests performed while or last before a user in â¹UIDsâº is friends with â¹UID1âº or â¹UID2âº.âº end

(* The value setup for friend confidentiality *) theory Friend_Request_Value_Setup imports Friend_Request_Intro begin text â¹The confidential information is the friendship requests between two arbitrary but fixed users:âº consts UID1 :: userID consts UID2 :: userID axiomatization where UID1_UID2_UIDs: "{UID1,UID2} â© UIDs = {}" and UID1_UID2: "UID1 â UID2" subsection â¹Preliminariesâº (* The notion of two userID lists being equal save for at most one occurrence of uid: *) fun eqButUIDl :: "userID â userID list â userID list â bool" where "eqButUIDl uid uidl uidl1 = (remove1 uid uidl = remove1 uid uidl1)" lemma eqButUIDl_eq[simp,intro!]: "eqButUIDl uid uidl uidl" by auto lemma eqButUIDl_sym: assumes "eqButUIDl uid uidl uidl1" shows "eqButUIDl uid uidl1 uidl" using assms by auto lemma eqButUIDl_trans: assumes "eqButUIDl uid uidl uidl1" and "eqButUIDl uid uidl1 uidl2" shows "eqButUIDl uid uidl uidl2" using assms by auto lemma eqButUIDl_remove1_cong: assumes "eqButUIDl uid uidl uidl1" shows "eqButUIDl uid (remove1 uid' uidl) (remove1 uid' uidl1)" proof - have "remove1 uid (remove1 uid' uidl) = remove1 uid' (remove1 uid uidl)" by (simp add: remove1_commute) also have "â¦ = remove1 uid' (remove1 uid uidl1)" using assms by simp also have "â¦ = remove1 uid (remove1 uid' uidl1)" by (simp add: remove1_commute) finally show ?thesis by simp qed lemma eqButUIDl_snoc_cong: assumes "eqButUIDl uid uidl uidl1" and "uid' ââ uidl â· uid' ââ uidl1" shows "eqButUIDl uid (uidl ## uid') (uidl1 ## uid')" using assms by (auto simp add: remove1_append remove1_idem) (* The notion of two functions each taking a userID and returning a list of user IDs being equal everywhere but on UID1 and UID2, where their return results are allowed to be eqButUIDl : *) definition eqButUIDf where "eqButUIDf frds frds1 â¡ eqButUIDl UID2 (frds UID1) (frds1 UID1) â§ eqButUIDl UID1 (frds UID2) (frds1 UID2) â§ (âuid. uid â UID1 â§ uid â UID2 â¶ frds uid = frds1 uid)" lemmas eqButUIDf_intro = eqButUIDf_def[THEN meta_eq_to_obj_eq, THEN iffD2] lemma eqButUIDf_eeq[simp,intro!]: "eqButUIDf frds frds" unfolding eqButUIDf_def by auto lemma eqButUIDf_sym: assumes "eqButUIDf frds frds1" shows "eqButUIDf frds1 frds" using assms eqButUIDl_sym unfolding eqButUIDf_def by presburger lemma eqButUIDf_trans: assumes "eqButUIDf frds frds1" and "eqButUIDf frds1 frds2" shows "eqButUIDf frds frds2" using assms eqButUIDl_trans unfolding eqButUIDf_def by (auto split: if_splits) lemma eqButUIDf_cong: assumes "eqButUIDf frds frds1" and "uid = UID1 â¹ eqButUIDl UID2 uu uu1" and "uid = UID2 â¹ eqButUIDl UID1 uu uu1" and "uid â UID1 â¹ uid â UID2 â¹ uu = uu1" shows "eqButUIDf (frds (uid := uu)) (frds1(uid := uu1))" using assms unfolding eqButUIDf_def by (auto split: if_splits) lemma eqButUIDf_eqButUIDl: assumes "eqButUIDf frds frds1" shows "eqButUIDl UID2 (frds UID1) (frds1 UID1)" and "eqButUIDl UID1 (frds UID2) (frds1 UID2)" using assms unfolding eqButUIDf_def by (auto split: if_splits) lemma eqButUIDf_not_UID: "â¦eqButUIDf frds frds1; uid â UID1; uid â UID2â§ â¹ frds uid = frds1 uid" unfolding eqButUIDf_def by (auto split: if_splits) lemma eqButUIDf_not_UID': assumes eq1: "eqButUIDf frds frds1" and uid: "(uid,uid') â {(UID1,UID2), (UID2,UID1)}" shows "uid ââ frds uid' â· uid ââ frds1 uid'" proof - from uid have "(uid' = UID1 â§ uid â UID2) â¨ (uid' = UID2 â§ uid â UID1) â¨ (uid' â {UID1,UID2})" (is "?u1 â¨ ?u2 â¨ ?n12") by auto then show ?thesis proof (elim disjE) assume "?u1" moreover then have "uid ââ remove1 UID2 (frds uid') â· uid ââ remove1 UID2 (frds1 uid')" using eq1 unfolding eqButUIDf_def by auto ultimately show ?thesis by auto next assume "?u2" moreover then have "uid ââ remove1 UID1 (frds uid') â· uid ââ remove1 UID1 (frds1 uid')" using eq1 unfolding eqButUIDf_def by auto ultimately show ?thesis by auto next assume "?n12" then show ?thesis using eq1 unfolding eqButUIDf_def by auto qed qed (* The notion of two functions each taking two userID arguments being equal everywhere but on the values (UID1,UID2) and (UID2,UID1): *) definition eqButUID12 where "eqButUID12 freq freq1 â¡ â uid uid'. if (uid,uid') â {(UID1,UID2), (UID2,UID1)} then True else freq uid uid' = freq1 uid uid'" lemmas eqButUID12_intro = eqButUID12_def[THEN meta_eq_to_obj_eq, THEN iffD2] lemma eqButUID12_eeq[simp,intro!]: "eqButUID12 freq freq" unfolding eqButUID12_def by auto lemma eqButUID12_sym: assumes "eqButUID12 freq freq1" shows "eqButUID12 freq1 freq" using assms unfolding eqButUID12_def by presburger lemma eqButUID12_trans: assumes "eqButUID12 freq freq1" and "eqButUID12 freq1 freq2" shows "eqButUID12 freq freq2" using assms unfolding eqButUID12_def by (auto split: if_splits) lemma eqButUID12_cong: assumes "eqButUID12 freq freq1" and "Â¬ (uid,uid') â {(UID1,UID2), (UID2,UID1)} â¹ uu = uu1" shows "eqButUID12 (fun_upd2 freq uid uid' uu) (fun_upd2 freq1 uid uid' uu1)" using assms unfolding eqButUID12_def fun_upd2_def by (auto split: if_splits) lemma eqButUID12_not_UID: "â¦eqButUID12 freq freq1; Â¬ (uid,uid') â {(UID1,UID2), (UID2,UID1)}â§ â¹ freq uid uid' = freq1 uid uid'" unfolding eqButUID12_def by (auto split: if_splits) (* The notion of two states being equal everywhere but on the friendship requests or status of users UID1 and UID2: *) definition eqButUID :: "state â state â bool" where "eqButUID s s1 â¡ admin s = admin s1 â§ pendingUReqs s = pendingUReqs s1 â§ userReq s = userReq s1 â§ userIDs s = userIDs s1 â§ user s = user s1 â§ pass s = pass s1 â§ eqButUIDf (pendingFReqs s) (pendingFReqs s1) â§ eqButUID12 (friendReq s) (friendReq s1) â§ eqButUIDf (friendIDs s) (friendIDs s1) â§ postIDs s = postIDs s1 â§ admin s = admin s1 â§ post s = post s1 â§ owner s = owner s1 â§ vis s = vis s1" lemmas eqButUID_intro = eqButUID_def[THEN meta_eq_to_obj_eq, THEN iffD2] lemma eqButUID_refl[simp,intro!]: "eqButUID s s" unfolding eqButUID_def by auto lemma eqButUID_sym[sym]: assumes "eqButUID s s1" shows "eqButUID s1 s" using assms eqButUIDf_sym eqButUID12_sym unfolding eqButUID_def by auto lemma eqButUID_trans[trans]: assumes "eqButUID s s1" and "eqButUID s1 s2" shows "eqButUID s s2" using assms eqButUIDf_trans eqButUID12_trans unfolding eqButUID_def by metis (* Implications from eqButUID, including w.r.t. auxiliary operations: *) lemma eqButUID_stateSelectors: "eqButUID s s1 â¹ admin s = admin s1 â§ pendingUReqs s = pendingUReqs s1 â§ userReq s = userReq s1 â§ userIDs s = userIDs s1 â§ user s = user s1 â§ pass s = pass s1 â§ eqButUIDf (pendingFReqs s) (pendingFReqs s1) â§ eqButUID12 (friendReq s) (friendReq s1) â§ eqButUIDf (friendIDs s) (friendIDs s1) â§ postIDs s = postIDs s1 â§ admin s = admin s1 â§ post s = post s1 â§ owner s = owner s1 â§ vis s = vis s1 â§ IDsOK s = IDsOK s1" unfolding eqButUID_def IDsOK_def[abs_def] by auto lemma eqButUID_eqButUID2: "eqButUID s s1 â¹ eqButUIDl UID2 (friendIDs s UID1) (friendIDs s1 UID1)" unfolding eqButUID_def using eqButUIDf_eqButUIDl by (smt eqButUIDf_eqButUIDl eqButUIDl.simps) lemma eqButUID_not_UID: "eqButUID s s1 â¹ uid â UID â¹ post s uid = post s1 uid" unfolding eqButUID_def by auto lemma eqButUID_cong[simp, intro]: "â uu1 uu2. eqButUID s s1 â¹ uu1 = uu2 â¹ eqButUID (s â¦admin := uu1â¦) (s1 â¦admin := uu2â¦)" "â uu1 uu2. eqButUID s s1 â¹ uu1 = uu2 â¹ eqButUID (s â¦pendingUReqs := uu1â¦) (s1 â¦pendingUReqs := uu2â¦)" "â uu1 uu2. eqButUID s s1 â¹ uu1 = uu2 â¹ eqButUID (s â¦userReq := uu1â¦) (s1 â¦userReq := uu2â¦)" "â uu1 uu2. eqButUID s s1 â¹ uu1 = uu2 â¹ eqButUID (s â¦userIDs := uu1â¦) (s1 â¦userIDs := uu2â¦)" "â uu1 uu2. eqButUID s s1 â¹ uu1 = uu2 â¹ eqButUID (s â¦user := uu1â¦) (s1 â¦user := uu2â¦)" "â uu1 uu2. eqButUID s s1 â¹ uu1 = uu2 â¹ eqButUID (s â¦pass := uu1â¦) (s1 â¦pass := uu2â¦)" "â uu1 uu2. eqButUID s s1 â¹ uu1 = uu2 â¹ eqButUID (s â¦postIDs := uu1â¦) (s1 â¦postIDs := uu2â¦)" "â uu1 uu2. eqButUID s s1 â¹ uu1 = uu2 â¹ eqButUID (s â¦owner := uu1â¦) (s1 â¦owner := uu2â¦)" "â uu1 uu2. eqButUID s s1 â¹ uu1 = uu2 â¹ eqButUID (s â¦post := uu1â¦) (s1 â¦post := uu2â¦)" "â uu1 uu2. eqButUID s s1 â¹ uu1 = uu2 â¹ eqButUID (s â¦vis := uu1â¦) (s1 â¦vis := uu2â¦)" "â uu1 uu2. eqButUID s s1 â¹ eqButUIDf uu1 uu2 â¹ eqButUID (s â¦pendingFReqs := uu1â¦) (s1 â¦pendingFReqs := uu2â¦)" "â uu1 uu2. eqButUID s s1 â¹ eqButUID12 uu1 uu2 â¹ eqButUID (s â¦friendReq := uu1â¦) (s1 â¦friendReq := uu2â¦)" "â uu1 uu2. eqButUID s s1 â¹ eqButUIDf uu1 uu2 â¹ eqButUID (s â¦friendIDs := uu1â¦) (s1 â¦friendIDs := uu2â¦)" unfolding eqButUID_def by auto subsectionâ¹Value Setupâº datatype "fUser" = U1 | U2 datatype "value" = isFRVal: FRVal fUser req â â¹friendship requests from â¹UID1âº to â¹UID2âº (or vice versa)âº | isFVal: FVal bool â â¹updates to the status of friendship between themâº | isOVal: OVal bool â â¹updated dynamic declassification trigger conditionâº text â¹The dynamic declassification trigger condition holds, i.e.~the access window to the confidential information is open, as long as the two users have not been created yet (so there cannot be friendship between them) or one of them is friends with an observer.âº definition openByA :: "state â bool" â â¹Openness by absenceâº where "openByA s â¡ Â¬ UID1 ââ userIDs s â¨ Â¬ UID2 ââ userIDs s" definition openByF :: "state â bool" â â¹Openness by friendshipâº where "openByF s â¡ âuid â UIDs. uid ââ friendIDs s UID1 â¨ uid ââ friendIDs s UID2" definition "open" :: "state â bool" where "open s â¡ openByA s â¨ openByF s" lemmas open_defs = open_def openByA_def openByF_def definition "friends12" :: "state â bool" where "friends12 s â¡ UID1 ââ friendIDs s UID2 â§ UID2 ââ friendIDs s UID1" fun Ï :: "(state,act,out) trans â bool" where "Ï (Trans s (Cact (cFriendReq uid p uid' req)) ou s') = ((uid,uid') â {(UID1,UID2), (UID2,UID1)} â§ ou = outOK)" | "Ï (Trans s (Cact (cFriend uid p uid')) ou s') = ((uid,uid') â {(UID1,UID2), (UID2,UID1)} â§ ou = outOK â¨ open s â open s')" | "Ï (Trans s (Dact (dFriend uid p uid')) ou s') = ((uid,uid') â {(UID1,UID2), (UID2,UID1)} â§ ou = outOK â¨ open s â open s')" | "Ï (Trans s (Cact (cUser uid p uid' p')) ou s') = (open s â open s')" | "Ï _ = False" fun f :: "(state,act,out) trans â value" where "f (Trans s (Cact (cFriendReq uid p uid' req)) ou s') = (if uid = UID1 â§ uid' = UID2 then FRVal U1 req else if uid = UID2 â§ uid' = UID1 then FRVal U2 req else OVal True)" | "f (Trans s (Cact (cFriend uid p uid')) ou s') = (if (uid,uid') â {(UID1,UID2), (UID2,UID1)} then FVal True else OVal True)" | "f (Trans s (Dact (dFriend uid p uid')) ou s') = (if (uid,uid') â {(UID1,UID2), (UID2,UID1)} then FVal False else OVal False)" | "f (Trans s (Cact (cUser uid p uid' p')) ou s') = OVal False" | "f _ = undefined" lemma ÏE: assumes Ï: "Ï (Trans s a ou s')" (is "Ï ?trn") and step: "step s a = (ou, s')" and rs: "reach s" obtains (FReq1) u p req where "a = Cact (cFriendReq UID1 p UID2 req)" "ou = outOK" "f ?trn = FRVal u req" "u = U1" "IDsOK s [UID1, UID2] []" "Â¬friends12 s" "Â¬friends12 s'" "open s' = open s" "UID1 ââ pendingFReqs s' UID2" "UID1 â set (pendingFReqs s UID2)" "UID2 ââ pendingFReqs s' UID1 â· UID2 ââ pendingFReqs s UID1" | (FReq2) u p req where "a = Cact (cFriendReq UID2 p UID1 req)" "ou = outOK" "f ?trn = FRVal u req" "u = U2" "IDsOK s [UID1, UID2] []" "Â¬friends12 s" "Â¬friends12 s'" "open s' = open s" "UID2 ââ pendingFReqs s' UID1" "UID2 â set (pendingFReqs s UID1)" "UID1 ââ pendingFReqs s' UID2 â· UID1 ââ pendingFReqs s UID2" | (Friend) uid p uid' where "a = Cact (cFriend uid p uid')" "ou = outOK" "f ?trn = FVal True" "uid = UID1 â§ uid' = UID2 â¨ uid = UID2 â§ uid' = UID1" "IDsOK s [UID1, UID2] []" "Â¬friends12 s" "friends12 s'" "uid' ââ pendingFReqs s uid" "UID1 â set (pendingFReqs s' UID2)" "UID2 â set (pendingFReqs s' UID1)" | (Unfriend) uid p uid' where "a = Dact (dFriend uid p uid')" "ou = outOK" "f ?trn = FVal False" "uid = UID1 â§ uid' = UID2 â¨ uid = UID2 â§ uid' = UID1" "IDsOK s [UID1, UID2] []" "friends12 s" "Â¬friends12 s'" "UID1 â set (pendingFReqs s' UID2)" "UID1 â set (pendingFReqs s UID2)" "UID2 â set (pendingFReqs s' UID1)" "UID2 â set (pendingFReqs s UID1)" | (OpenF) uid p uid' where "a = Cact (cFriend uid p uid')" "(uid â UIDs â§ uid' â {UID1,UID2}) â¨ (uid' â UIDs â§ uid â {UID1,UID2})" "ou = outOK" "f ?trn = OVal True" "Â¬openByF s" "openByF s'" "Â¬openByA s" "Â¬openByA s'" "friends12 s' = friends12 s" "UID1 ââ pendingFReqs s' UID2 â· UID1 ââ pendingFReqs s UID2" "UID2 ââ pendingFReqs s' UID1 â· UID2 ââ pendingFReqs s UID1" | (CloseF) uid p uid' where "a = Dact (dFriend uid p uid')" "(uid â UIDs â§ uid' â {UID1,UID2}) â¨ (uid' â UIDs â§ uid â {UID1,UID2})" "ou = outOK" "f ?trn = OVal False" "openByF s" "Â¬openByF s'" "Â¬openByA s" "Â¬openByA s'" "friends12 s' = friends12 s" "UID1 ââ pendingFReqs s' UID2 â· UID1 ââ pendingFReqs s UID2" "UID2 ââ pendingFReqs s' UID1 â· UID2 ââ pendingFReqs s UID1" | (CloseA) uid p uid' p' where "a = Cact (cUser uid p uid' p')" "uid' â {UID1,UID2}" "openByA s" "Â¬openByA s'" "Â¬openByF s" "Â¬openByF s'" "ou = outOK" "f ?trn = OVal False" "friends12 s' = friends12 s" "UID1 ââ pendingFReqs s' UID2 â· UID1 ââ pendingFReqs s UID2" "UID2 ââ pendingFReqs s' UID1 â· UID2 ââ pendingFReqs s UID1" using Ï proof (elim Ï.elims disjE conjE) fix s1 uid p uid' req ou1 s1' assume "(uid,uid') â {(UID1,UID2), (UID2,UID1)}" and ou: "ou1 = outOK" and "?trn = Trans s1 (Cact (cFriendReq uid p uid' req)) ou1 s1'" then have trn: "a = Cact (cFriendReq uid p uid' req)" "s = s1" "s' = s1'" "ou = ou1" and uids: "uid = UID1 â§ uid' = UID2 â¨ uid = UID2 â§ uid' = UID1" using UID1_UID2 by auto from uids show thesis proof assume "uid = UID1 â§ uid' = UID2" then show thesis using ou uids trn step UID1_UID2_UIDs UID1_UID2 reach_distinct_friends_reqs[OF rs] by (intro FReq1[of p req]) (auto simp add: c_defs friends12_def open_defs) next assume "uid = UID2 â§ uid' = UID1" then show thesis using ou uids trn step UID1_UID2_UIDs UID1_UID2 reach_distinct_friends_reqs[OF rs] by (intro FReq2[of p req]) (auto simp add: c_defs friends12_def open_defs) qed next fix s1 uid p uid' ou1 s1' assume "(uid,uid') â {(UID1,UID2), (UID2,UID1)}" and ou: "ou1 = outOK" and "?trn = Trans s1 (Cact (cFriend uid p uid')) ou1 s1'" then have trn: "a = Cact (cFriend uid p uid')" "s = s1" "s' = s1'" "ou = ou1" and uids: "uid = UID1 â§ uid' = UID2 â¨ uid = UID2 â§ uid' = UID1" using UID1_UID2 by auto then show thesis using ou uids trn step UID1_UID2_UIDs UID1_UID2 reach_distinct_friends_reqs[OF rs] by (intro Friend[of uid p uid']) (auto simp add: c_defs friends12_def) next fix s1 uid p uid' ou1 s1' assume op: "open s1 â open s1'" and "?trn = Trans s1 (Cact (cFriend uid p uid')) ou1 s1'" then have trn: "a = Cact (cFriend uid p uid')" "s = s1" "s' = s1'" "ou = ou1" by auto then have uids: "uid â UIDs â§ uid' â {UID1, UID2} â¨ uid â {UID1, UID2} â§ uid' â UIDs" "ou = outOK" "Â¬openByF s1" "openByF s1'" "Â¬openByA s1" "Â¬openByA s1'" using op step by (auto simp add: c_defs open_def openByA_def openByF_def) moreover have "friends12 s1' â· friends12 s1" using step trn uids UID1_UID2 UID1_UID2_UIDs by (cases "(uid,uid') â {(UID1,UID2), (UID2,UID1)}") (auto simp add: c_defs friends12_def) moreover have "UID1 ââ pendingFReqs s1' UID2 â· UID1 ââ pendingFReqs s1 UID2" using step trn uids UID1_UID2 UID1_UID2_UIDs by (cases "(uid,uid') â {(UID1,UID2), (UID2,UID1)}") (auto simp add: c_defs) moreover have "UID2 ââ pendingFReqs s1' UID1 â· UID2 ââ pendingFReqs s1 UID1" using step trn uids UID1_UID2 UID1_UID2_UIDs by (cases "(uid,uid') â {(UID1,UID2), (UID2,UID1)}") (auto simp add: c_defs) ultimately show thesis using op trn step UID1_UID2_UIDs UID1_UID2 by (intro OpenF) auto next fix s1 uid p uid' ou1 s1' assume "(uid,uid') â {(UID1,UID2), (UID2,UID1)}" and ou: "ou1 = outOK" and "?trn = Trans s1 (Dact (dFriend uid p uid')) ou1 s1'" then have trn: "a = Dact (dFriend uid p uid')" "s = s1" "s' = s1'" "ou = ou1" and uids: "uid = UID1 â§ uid' = UID2 â¨ uid = UID2 â§ uid' = UID1" using UID1_UID2 by auto then show thesis using step ou reach_friendIDs_symmetric[OF rs] reach_distinct_friends_reqs[OF rs] by (intro Unfriend; auto simp: d_defs friends12_def) blast+ next fix s1 uid p uid' ou1 s1' assume op: "open s1 â open s1'" and "?trn = Trans s1 (Dact (dFriend uid p uid')) ou1 s1'" then have trn: "a = Dact (dFriend uid p uid')" "s = s1" "s' = s1'" "ou = ou1" by auto then have uids: "uid â UIDs â§ uid' â {UID1, UID2} â¨ uid â {UID1, UID2} â§ uid' â UIDs" "ou = outOK" "openByF s1" "Â¬openByF s1'" "Â¬openByA s1" "Â¬openByA s1'" using op step by (auto simp add: d_defs open_def openByA_def openByF_def) moreover have "friends12 s1' â· friends12 s1" using step trn uids UID1_UID2 UID1_UID2_UIDs by (cases "(uid,uid') â {(UID1,UID2), (UID2,UID1)}") (auto simp add: d_defs friends12_def) ultimately show thesis using op trn step UID1_UID2_UIDs UID1_UID2 by (intro CloseF; auto simp: d_defs) next fix s1 uid p uid' p' ou1 s1' assume op: "open s1 â open s1'" and "?trn = Trans s1 (Cact (cUser uid p uid' p')) ou1 s1'" then have trn: "a = Cact (cUser uid p uid' p')" "s = s1" "s' = s1'" "ou = ou1" by auto then have uids: "uid' = UID2 â¨ uid' = UID1" "ou = outOK" "Â¬openByF s1" "Â¬openByF s1'" "openByA s1" "Â¬openByA s1'" using op step by (auto simp add: c_defs open_def openByF_def openByA_def) moreover have "friends12 s1' â· friends12 s1" using step trn uids UID1_UID2 UID1_UID2_UIDs by (cases "(uid,uid') â {(UID1,UID2), (UID2,UID1)}") (auto simp add: c_defs friends12_def) ultimately show thesis using trn step UID1_UID2_UIDs UID1_UID2 by (intro CloseA) (auto simp: c_defs) qed lemma step_open_Ï: assumes "step s a = (ou, s')" and "open s â open s'" shows "Ï (Trans s a ou s')" using assms proof (cases a) case (Sact sa) then show ?thesis using assms UID1_UID2 by (cases sa) (auto simp: s_defs open_defs) next case (Cact ca) then show ?thesis using assms by (cases ca) (auto simp: c_defs open_defs) next case (Dact da) then show ?thesis using assms by (cases da) (auto simp: d_defs open_defs) next case (Uact ua) then show ?thesis using assms by (cases ua) (auto simp: u_defs open_defs) qed auto lemma step_friends12_Ï: assumes "step s a = (ou, s')" and "friends12 s â friends12 s'" shows "Ï (Trans s a ou s')" using assms proof (cases a) case (Sact sa) then show ?thesis using assms by (cases sa) (auto simp: s_defs friends12_def) next case (Cact ca) then show ?thesis using assms by (cases ca) (auto simp: c_defs friends12_def) next case (Dact da) then show ?thesis using assms by (cases da) (auto simp: d_defs friends12_def) next case (Uact ua) then show ?thesis using assms by (cases ua) (auto simp: u_defs friends12_def) qed auto lemma step_pendingFReqs_Ï: assumes "step s a = (ou, s')" and "(UID1 ââ pendingFReqs s UID2) â (UID1 ââ pendingFReqs s' UID2) â¨ (UID2 ââ pendingFReqs s UID1) â (UID2 ââ pendingFReqs s' UID1)" shows "Ï (Trans s a ou s')" using assms proof (cases a) case (Sact sa) then show ?thesis using assms by (cases sa) (auto simp: s_defs) next case (Cact ca) then show ?thesis using assms by (cases ca) (auto simp: c_defs) next case (Dact da) then show ?thesis using assms by (cases da) (auto simp: d_defs) next case (Uact ua) then show ?thesis using assms by (cases ua) (auto simp: u_defs) qed auto lemma eqButUID_friends12_set_friendIDs_eq: assumes ss1: "eqButUID s s1" and f12: "friends12 s = friends12 s1" and rs: "reach s" and rs1: "reach s1" shows "set (friendIDs s uid) = set (friendIDs s1 uid)" proof - have dfIDs: "distinct (friendIDs s uid)" "distinct (friendIDs s1 uid)" using reach_distinct_friends_reqs[OF rs] reach_distinct_friends_reqs[OF rs1] by auto from f12 have uid12: "UID1 ââ friendIDs s UID2 â· UID1 ââ friendIDs s1 UID2" "UID2 ââ friendIDs s UID1 â· UID2 ââ friendIDs s1 UID1" using reach_friendIDs_symmetric[OF rs] reach_friendIDs_symmetric[OF rs1] unfolding friends12_def by auto from ss1 have fIDs: "eqButUIDf (friendIDs s) (friendIDs s1)" unfolding eqButUID_def by simp show "set (friendIDs s uid) = set (friendIDs s1 uid)" proof (intro equalityI subsetI) fix uid' assume "uid' ââ friendIDs s uid" then show "uid' ââ friendIDs s1 uid" using fIDs dfIDs uid12 eqButUIDf_not_UID' unfolding eqButUIDf_def by (metis (no_types, lifting) insert_iff prod.inject singletonD) next fix uid' assume "uid' ââ friendIDs s1 uid" then show "uid' ââ friendIDs s uid" using fIDs dfIDs uid12 eqButUIDf_not_UID' unfolding eqButUIDf_def by (metis (no_types, lifting) insert_iff prod.inject singletonD) qed qed lemma distinct_remove1_idem: "distinct xs â¹ remove1 y (remove1 y xs) = remove1 y xs" by (induction xs) (auto simp add: remove1_idem) lemma Cact_cFriend_step_eqButUID: assumes step: "step s (Cact (cFriend uid p uid')) = (ou,s')" and s: "reach s" and uids: "(uid = UID1 â§ uid' = UID2) â¨ (uid = UID2 â§ uid' = UID1)" (is "?u12 â¨ ?u21") shows "eqButUID s s'" using assms proof (cases) assume ou: "ou = outOK" then have "uid' ââ pendingFReqs s uid" using step by (auto simp add: c_defs) then have fIDs: "uid' â set (friendIDs s uid)" "uid â set (friendIDs s uid')" and fRs: "distinct (pendingFReqs s uid)" "distinct (pendingFReqs s uid')" using reach_distinct_friends_reqs[OF s] by auto have "eqButUIDf (friendIDs s) (friendIDs (createFriend s uid p uid'))" using fIDs uids UID1_UID2 unfolding eqButUIDf_def by (cases "?u12") (auto simp add: c_defs remove1_idem remove1_append) moreover have "eqButUIDf (pendingFReqs s) (pendingFReqs (createFriend s uid p uid'))" using fRs uids UID1_UID2 unfolding eqButUIDf_def by (cases "?u12") (auto simp add: c_defs distinct_remove1_idem) moreover have "eqButUID12 (friendReq s) (friendReq (createFriend s uid p uid'))" using uids unfolding eqButUID12_def by (auto simp add: c_defs fun_upd2_eq_but_a_b) ultimately show "eqButUID s s'" using step ou unfolding eqButUID_def by (auto simp add: c_defs) qed (auto) lemma Cact_cFriendReq_step_eqButUID: assumes step: "step s (Cact (cFriendReq uid p uid' req)) = (ou,s')" and uids: "(uid = UID1 â§ uid' = UID2) â¨ (uid = UID2 â§ uid' = UID1)" (is "?u12 â¨ ?u21") shows "eqButUID s s'" using assms proof (cases) assume ou: "ou = outOK" then have "uid â set (pendingFReqs s uid')" "uid â set (friendIDs s uid')" using step by (auto simp add: c_defs) then have "eqButUIDf (pendingFReqs s) (pendingFReqs (createFriendReq s uid p uid' req))" using uids UID1_UID2 unfolding eqButUIDf_def by (cases "?u12") (auto simp add: c_defs remove1_idem remove1_append) moreover have "eqButUID12 (friendReq s) (friendReq (createFriendReq s uid p uid' req))" using uids unfolding eqButUID12_def by (auto simp add: c_defs fun_upd2_eq_but_a_b) ultimately show "eqButUID s s'" using step ou unfolding eqButUID_def by (auto simp add: c_defs) qed (auto) lemma Dact_dFriend_step_eqButUID: assumes step: "step s (Dact (dFriend uid p uid')) = (ou,s')" and s: "reach s" and uids: "(uid = UID1 â§ uid' = UID2) â¨ (uid = UID2 â§ uid' = UID1)" (is "?u12 â¨ ?u21") shows "eqButUID s s'" using assms proof (cases) assume ou: "ou = outOK" then have "uid' ââ friendIDs s uid" using step by (auto simp add: d_defs) then have fRs: "distinct (friendIDs s uid)" "distinct (friendIDs s uid')" using reach_distinct_friends_reqs[OF s] by auto have "eqButUIDf (friendIDs s) (friendIDs (deleteFriend s uid p uid'))" using fRs uids UID1_UID2 unfolding eqButUIDf_def by (cases "?u12") (auto simp add: d_defs remove1_idem distinct_remove1_removeAll) then show "eqButUID s s'" using step ou unfolding eqButUID_def by (auto simp add: d_defs) qed (auto) (* Key lemma: *) lemma eqButUID_step: assumes ss1: "eqButUID s s1" and step: "step s a = (ou,s')" and step1: "step s1 a = (ou1,s1')" and rs: "reach s" and rs1: "reach s1" shows "eqButUID s' s1'" proof - note simps = eqButUID_def s_defs c_defs u_defs r_defs l_defs from assms show ?thesis proof (cases a) case (Sact sa) with assms show ?thesis by (cases sa) (auto simp add: simps) next case (Cact ca) note a = this with assms show ?thesis proof (cases ca) case (cFriendReq uid p uid' req) note ca = this then show ?thesis proof (cases "(uid = UID1 â§ uid' = UID2) â¨ (uid = UID2 â§ uid' = UID1)") case True then have "eqButUID s s'" and "eqButUID s1 s1'" using step step1 unfolding a ca by (auto intro: Cact_cFriendReq_step_eqButUID) with ss1 show "eqButUID s' s1'" by (auto intro: eqButUID_sym eqButUID_trans) next case False have fRs: "eqButUIDf (pendingFReqs s) (pendingFReqs s1)" and fIDs: "eqButUIDf (friendIDs s) (friendIDs s1)" using ss1 by (auto simp: simps) then have uid_uid': "uid ââ pendingFReqs s uid' â· uid ââ pendingFReqs s1 uid'" "uid ââ friendIDs s uid' â· uid ââ friendIDs s1 uid'" using False by (auto intro!: eqButUIDf_not_UID') have "eqButUIDf ((pendingFReqs s)(uid' := pendingFReqs s uid' ## uid)) ((pendingFReqs s1)(uid' := pendingFReqs s1 uid' ## uid))" using fRs False by (intro eqButUIDf_cong) (auto simp add: remove1_append remove1_idem eqButUIDf_def) moreover have "eqButUID12 (fun_upd2 (friendReq s) uid uid' req) (fun_upd2 (friendReq s1) uid uid' req)" using ss1 by (intro eqButUID12_cong) (auto simp: simps) moreover have "e_createFriendReq s uid p uid' req â· e_createFriendReq s1 uid p uid' req" using uid_uid' ss1 by (auto simp: simps) ultimately show ?thesis using assms unfolding a ca by (auto simp: simps) qed next case (cFriend uid p uid') note ca = this then show ?thesis proof (cases "(uid = UID1 â§ uid' = UID2) â¨ (uid = UID2 â§ uid' = UID1)") case True then have "eqButUID s s'" and "eqButUID s1 s1'" using step step1 rs rs1 unfolding a ca by (auto intro!: Cact_cFriend_step_eqButUID)+ with ss1 show "eqButUID s' s1'" by (auto intro: eqButUID_sym eqButUID_trans) next case False have fRs: "eqButUIDf (pendingFReqs s) (pendingFReqs s1)" (is "eqButUIDf (?pfr s) (?pfr s1)") and fIDs: "eqButUIDf (friendIDs s) (friendIDs s1)" using ss1 by (auto simp: simps) then have uid_uid': "uid ââ pendingFReqs s uid' â· uid ââ pendingFReqs s1 uid'" "uid' ââ pendingFReqs s uid â· uid' ââ pendingFReqs s1 uid" "uid ââ friendIDs s uid' â· uid ââ friendIDs s1 uid'" "uid' ââ friendIDs s uid â· uid' ââ friendIDs s1 uid" using False by (auto intro!: eqButUIDf_not_UID') have "eqButUIDl UID1 (remove1 uid' (?pfr s UID2)) (remove1 uid' (?pfr s1 UID2))" and "eqButUIDl UID2 (remove1 uid' (?pfr s UID1)) (remove1 uid' (?pfr s1 UID1))" and "eqButUIDl UID1 (remove1 uid (?pfr s UID2)) (remove1 uid (?pfr s1 UID2))" and "eqButUIDl UID2 (remove1 uid (?pfr s UID1)) (remove1 uid (?pfr s1 UID1))" using fRs unfolding eqButUIDf_def by (auto intro!: eqButUIDl_remove1_cong simp del: eqButUIDl.simps) then have 1: "eqButUIDf ((?pfr s)(uid := remove1 uid' (?pfr s uid), uid' := remove1 uid (?pfr s uid'))) ((?pfr s1)(uid := remove1 uid' (?pfr s1 uid), uid' := remove1 uid (?pfr s1 uid')))" using fRs False by (intro eqButUIDf_cong) (auto simp add: eqButUIDf_def) have "uid = UID1 â¹ eqButUIDl UID2 (friendIDs s UID1 ## uid') (friendIDs s1 UID1 ## uid')" and "uid = UID2 â¹ eqButUIDl UID1 (friendIDs s UID2 ## uid') (friendIDs s1 UID2 ## uid')" and "uid' = UID1 â¹ eqButUIDl UID2 (friendIDs s UID1 ## uid) (friendIDs s1 UID1 ## uid)" and "uid' = UID2 â¹ eqButUIDl UID1 (friendIDs s UID2 ## uid) (friendIDs s1 UID2 ## uid)" using fIDs uid_uid' by - (intro eqButUIDl_snoc_cong; simp add: eqButUIDf_def)+ then have 2: "eqButUIDf ((friendIDs s)(uid := friendIDs s uid ## uid', uid' := friendIDs s uid' ## uid)) ((friendIDs s1)(uid := friendIDs s1 uid ## uid', uid' := friendIDs s1 uid' ## uid))" using fIDs by (intro eqButUIDf_cong) (auto simp add: eqButUIDf_def) have 3: "eqButUID12 (fun_upd2 (fun_upd2 (friendReq s) uid' uid emptyReq) uid uid' emptyReq) (fun_upd2 (fun_upd2 (friendReq s1) uid' uid emptyReq) uid uid' emptyReq)" using ss1 by (intro eqButUID12_cong) (auto simp: simps) have "e_createFriend s uid p uid' â· e_createFriend s1 uid p uid'" using uid_uid' ss1 by (auto simp: simps) with 1 2 3 show ?thesis using assms unfolding a ca by (auto simp: simps) qed qed (auto simp: simps) next case (Uact ua) with assms show ?thesis by (cases ua) (auto simp add: simps) next case (Ract ra) with assms show ?thesis by (cases ra) (auto simp add: simps) next case (Lact la) with assms show ?thesis by (cases la) (auto simp add: simps) next case (Dact da) note a = this with assms show ?thesis proof (cases da) case (dFriend uid p uid') note ca = this then show ?thesis proof (cases "(uid = UID1 â§ uid' = UID2) â¨ (uid = UID2 â§ uid' = UID1)") case True then have "eqButUID s s'" and "eqButUID s1 s1'" using step step1 rs rs1 unfolding a ca by (auto intro!: Dact_dFriend_step_eqButUID)+ with ss1 show "eqButUID s' s1'" by (auto intro: eqButUID_sym eqButUID_trans) next case False have fIDs: "eqButUIDf (friendIDs s) (friendIDs s1)" using ss1 by (auto simp: simps) then have uid_uid': "uid ââ friendIDs s uid' â· uid ââ friendIDs s1 uid'" "uid' ââ friendIDs s uid â· uid' ââ friendIDs s1 uid" using False by (auto intro!: eqButUIDf_not_UID') have dfIDs: "distinct (friendIDs s uid)" "distinct (friendIDs s uid')" "distinct (friendIDs s1 uid)" "distinct (friendIDs s1 uid')" using reach_distinct_friends_reqs[OF rs] reach_distinct_friends_reqs[OF rs1] by auto have "uid = UID1 â¹ eqButUIDl UID2 (remove1 uid' (friendIDs s UID1)) (remove1 uid' (friendIDs s1 UID1))" and "uid = UID2 â¹ eqButUIDl UID1 (remove1 uid' (friendIDs s UID2)) (remove1 uid' (friendIDs s1 UID2))" and "uid' = UID1 â¹ eqButUIDl UID2 (remove1 uid (friendIDs s UID1)) (remove1 uid (friendIDs s1 UID1))" and "uid' = UID2 â¹ eqButUIDl UID1 (remove1 uid (friendIDs s UID2)) (remove1 uid (friendIDs s1 UID2))" using fIDs uid_uid' by - (intro eqButUIDl_remove1_cong; simp add: eqButUIDf_def)+ then have 1: "eqButUIDf ((friendIDs s)(uid := remove1 uid' (friendIDs s uid), uid' := remove1 uid (friendIDs s uid'))) ((friendIDs s1)(uid := remove1 uid' (friendIDs s1 uid), uid' := remove1 uid (friendIDs s1 uid')))" using fIDs by (intro eqButUIDf_cong) (auto simp add: eqButUIDf_def) have "e_deleteFriend s uid p uid' â· e_deleteFriend s1 uid p uid'" using uid_uid' ss1 by (auto simp: simps d_defs) with 1 show ?thesis using assms dfIDs unfolding a ca by (auto simp: simps d_defs distinct_remove1_removeAll) qed qed qed qed lemma eqButUID_openByA_eq: assumes "eqButUID s s1" shows "openByA s = openByA s1" using assms unfolding openByA_def eqButUID_def by auto lemma eqButUID_openByF_eq: assumes ss1: "eqButUID s s1" shows "openByF s = openByF s1" proof - from ss1 have fIDs: "eqButUIDf (friendIDs s) (friendIDs s1)" unfolding eqButUID_def by auto have "âuid â UIDs. uid ââ friendIDs s UID1 â· uid ââ friendIDs s1 UID1" using UID1_UID2_UIDs UID1_UID2 by (intro ballI eqButUIDf_not_UID'[OF fIDs]; auto) moreover have "âuid â UIDs. uid ââ friendIDs s UID2 â· uid ââ friendIDs s1 UID2" using UID1_UID2_UIDs UID1_UID2 by (intro ballI eqButUIDf_not_UID'[OF fIDs]; auto) ultimately show "openByF s = openByF s1" unfolding openByF_def by auto qed lemma eqButUID_open_eq: "eqButUID s s1 â¹ open s = open s1" using eqButUID_openByA_eq eqButUID_openByF_eq unfolding open_def by blast lemma eqButUID_step_friendIDs_eq: assumes ss1: "eqButUID s s1" and rs: "reach s" and rs1: "reach s1" and step: "step s a = (ou,s')" and step1: "step s1 a = (ou1,s1')" and a: "a â Cact (cFriend UID1 (pass s UID1) UID2) â§ a â Cact (cFriend UID2 (pass s UID2) UID1) â§ a â Dact (dFriend UID1 (pass s UID1) UID2) â§ a â Dact (dFriend UID2 (pass s UID2) UID1)" and "friendIDs s = friendIDs s1" shows "friendIDs s' = friendIDs s1'" using assms proof (cases a) case (Sact sa) then show ?thesis using assms by (cases sa) (auto simp: s_defs) next case (Uact ua) then show ?thesis using assms by (cases ua) (auto simp: u_defs) next case (Dact da) then show ?thesis using assms proof (cases da) case (dFriend uid p uid') with Dact assms show ?thesis by (cases "(uid,uid') â {(UID1,UID2), (UID2,UID1)}") (auto simp: d_defs eqButUID_def eqButUIDf_not_UID') qed next case (Cact ca) then show ?thesis using assms proof (cases ca) case (cFriend uid p uid') with Cact assms show ?thesis by (cases "(uid,uid') â {(UID1,UID2), (UID2,UID1)}") (auto simp: c_defs eqButUID_def eqButUIDf_not_UID') qed (auto simp: c_defs) qed auto lemma eqButUID_step_Ï_imp: assumes ss1: "eqButUID s s1" and rs: "reach s" and rs1: "reach s1" and step: "step s a = (ou,s')" and step1: "step s1 a = (ou1,s1')" and a: "âreq. a â Cact (cFriend UID1 (pass s UID1) UID2) â§ a â Cact (cFriend UID2 (pass s UID2) UID1) â§ a â Cact (cFriendReq UID1 (pass s UID1) UID2 req) â§ a â Cact (cFriendReq UID2 (pass s UID2) UID1 req) â§ a â Dact (dFriend UID1 (pass s UID1) UID2) â§ a â Dact (dFriend UID2 (pass s UID2) UID1)" and Ï: "Ï (Trans s a ou s')" shows "Ï (Trans s1 a ou1 s1')" proof - have "eqButUID s' s1'" using eqButUID_step[OF ss1 step step1 rs rs1] . then have "open s = open s1" and "open s' = open s1'" and "openByA s = openByA s1" and "openByA s' = openByA s1'" and "openByF s = openByF s1" and "openByF s' = openByF s1'" using ss1 by (auto simp: eqButUID_open_eq eqButUID_openByA_eq eqButUID_openByF_eq) with Ï a step step1 show "Ï (Trans s1 a ou1 s1')" using UID1_UID2_UIDs by (elim Ï.elims) (auto simp: c_defs d_defs) qed (* Key lemma: *) lemma eqButUID_step_Ï: assumes ss1: "eqButUID s s1" and rs: "reach s" and rs1: "reach s1" and step: "step s a = (ou,s')" and step1: "step s1 a = (ou1,s1')" and a: "âreq. a â Cact (cFriend UID1 (pass s UID1) UID2) â§ a â Cact (cFriend UID2 (pass s UID2) UID1) â§ a â Cact (cFriendReq UID1 (pass s UID1) UID2 req) â§ a â Cact (cFriendReq UID2 (pass s UID2) UID1 req) â§ a â Dact (dFriend UID1 (pass s UID1) UID2) â§ a â Dact (dFriend UID2 (pass s UID2) UID1)" shows "Ï (Trans s a ou s') = Ï (Trans s1 a ou1 s1')" proof assume "Ï (Trans s a ou s')" with assms show "Ï (Trans s1 a ou1 s1')" by (rule eqButUID_step_Ï_imp) next assume "Ï (Trans s1 a ou1 s1')" moreover have "eqButUID s1 s" using ss1 by (rule eqButUID_sym) moreover have "âreq. a â Cact (cFriend UID1 (pass s1 UID1) UID2) â§ a â Cact (cFriend UID2 (pass s1 UID2) UID1) â§ a â Cact (cFriendReq UID1 (pass s1 UID1) UID2 req) â§ a â Cact (cFriendReq UID2 (pass s1 UID2) UID1 req) â§ a â Dact (dFriend UID1 (pass s1 UID1) UID2) â§ a â Dact (dFriend UID2 (pass s1 UID2) UID1)" using a ss1 unfolding eqButUID_def by auto ultimately show "Ï (Trans s a ou s')" using rs rs1 step step1 by (intro eqButUID_step_Ï_imp[of s1 s]) qed lemma createFriend_sym: "createFriend s uid p uid' = createFriend s uid' p' uid" unfolding c_defs by (cases "uid = uid'") (auto simp: fun_upd2_comm fun_upd_twist) lemma deleteFriend_sym: "deleteFriend s uid p uid' = deleteFriend s uid' p' uid" unfolding d_defs by (cases "uid = uid'") (auto simp: fun_upd_twist) lemma createFriendReq_createFriend_absorb: assumes "e_createFriendReq s uid' p uid req" shows "createFriend (createFriendReq s uid' p1 uid req) uid p2 uid' = createFriend s uid p3 uid'" using assms unfolding c_defs by (auto simp: remove1_idem remove1_append fun_upd2_absorb) lemma eqButUID_deleteFriend12_friendIDs_eq: assumes ss1: "eqButUID s s1" and rs: "reach s" and rs1: "reach s1" shows "friendIDs (deleteFriend s UID1 p UID2) = friendIDs (deleteFriend s1 UID1 p' UID2)" proof - have "distinct (friendIDs s UID1)" "distinct (friendIDs s UID2)" "distinct (friendIDs s1 UID1)" "distinct (friendIDs s1 UID2)" using rs rs1 by (auto intro: reach_distinct_friends_reqs) then show ?thesis using ss1 unfolding eqButUID_def eqButUIDf_def unfolding d_defs by (auto simp: distinct_remove1_removeAll) qed lemma eqButUID_createFriend12_friendIDs_eq: assumes ss1: "eqButUID s s1" and rs: "reach s" and rs1: "reach s1" and f12: "Â¬friends12 s" "Â¬friends12 s1" shows "friendIDs (createFriend s UID1 p UID2) = friendIDs (createFriend s1 UID1 p' UID2)" proof - have f12': "UID1 â set (friendIDs s UID2)" "UID2 â set (friendIDs s UID1)" "UID1 â set (friendIDs s1 UID2)" "UID2 â set (friendIDs s1 UID1)" using f12 rs rs1 reach_friendIDs_symmetric unfolding friends12_def by auto have "friendIDs s = friendIDs s1" proof (intro ext) fix uid show "friendIDs s uid = friendIDs s1 uid" using ss1 f12' unfolding eqButUID_def eqButUIDf_def by (cases "uid = UID1 â¨ uid = UID2") (auto simp: remove1_idem) qed then show ?thesis by (auto simp: c_defs) qed end

theory Friend_Request imports "../Observation_Setup" Friend_Request_Value_Setup begin subsection â¹Declassification boundâº fun T :: "(state,act,out) trans â bool" where "T (Trans _ _ _ _) = False" text â¹Friendship updates form an alternating sequence of friending and unfriending, and every successful friend creation is preceded by one or two friendship requests.âº fun validValSeq :: "value list â bool â bool â bool â bool" where "validValSeq [] _ _ _ = True" | "validValSeq (FRVal U1 req # vl) st r1 r2 â· (Â¬st) â§ (Â¬r1) â§ validValSeq vl st True r2" | "validValSeq (FRVal U2 req # vl) st r1 r2 â· (Â¬st) â§ (Â¬r2) â§ validValSeq vl st r1 True" | "validValSeq (FVal True # vl) st r1 r2 â· (Â¬st) â§ (r1 â¨ r2) â§ validValSeq vl True False False" | "validValSeq (FVal False # vl) st r1 r2 â· st â§ (Â¬r1) â§ (Â¬r2) â§ validValSeq vl False False False" | "validValSeq (OVal True # vl) st r1 r2 â· validValSeq vl st r1 r2" | "validValSeq (OVal False # vl) st r1 r2 â· validValSeq vl st r1 r2" abbreviation validValSeqFrom :: "value list â state â bool" where "validValSeqFrom vl s â¡ validValSeq vl (friends12 s) (UID1 ââ pendingFReqs s UID2) (UID2 ââ pendingFReqs s UID1)" text â¹With respect to the friendship status updates, we use the same ``while-or-last-before'' bound as for friendship status confidentiality.âº inductive BO :: "value list â value list â bool" and BC :: "value list â value list â bool" where BO_FVal[simp,intro!]: "BO (map FVal fs) (map FVal fs)" |BO_BC[intro]: "BC vl vl1 â¹ BO (map FVal fs @ OVal False # vl) (map FVal fs @ OVal False # vl1)" (* *) |BC_FVal[simp,intro!]: "BC (map FVal fs) (map FVal fs1)" |BC_BO[intro]: "BO vl vl1 â¹ (fs = [] â· fs1 = []) â¹ (fs â [] â¹ last fs = last fs1) â¹ BC (map FVal fs @ OVal True # vl) (map FVal fs1 @ OVal True # vl1)" text â¹Taking into account friendship requests, two value sequences â¹vlâº and â¹vl1âº are in the bound if âª â¹vl1âº (with friendship requests) forms a valid value sequence, âª â¹vlâº and â¹vl1âº are in â¹BOâº (without friendship requests), âª â¹vl1âº is empty if â¹vlâº is empty, and âª â¹vl1âº begins with termâ¹OVal Falseâº if â¹vlâº begins with termâ¹OVal Falseâº. The last two points are due to the fact that termâ¹UID1âº and termâ¹UID1âº might not exist yet if â¹vlâº is empty (or before termâ¹OVal Falseâº), in which case the observer can deduce that no friendship request has happened yet.âº definition "B vl vl1 â¡ BO (filter (Not o isFRVal) vl) (filter (Not o isFRVal) vl1) â§ validValSeqFrom vl1 istate â§ (vl = [] â¶ vl1 = []) â§ (vl â [] â§ hd vl = OVal False â¶ vl1 â [] â§ hd vl1 = OVal False)" lemma BO_Nil_iff: "BO vl vl1 â¹ vl = [] â· vl1 = []" by (cases rule: BO.cases) auto no_notation relcomp (infixr "O" 75) interpretation BD_Security_IO where istate = istate and step = step and Ï = Ï and f = f and Î³ = Î³ and g = g and T = T and B = B done (* sanity check *) lemma validFrom_validValSeq: assumes "validFrom s tr" and "reach s" shows "validValSeqFrom (V tr) s" using assms proof (induction tr arbitrary: s) case (Cons trn tr s) then obtain a ou s' where trn: "trn = Trans s a ou s'" and step: "step s a = (ou, s')" and tr: "validFrom s' tr" and s': "reach s'" by (cases trn) (auto iff: validFrom_Cons intro: reach_PairI) then have vVS_tr: "validValSeqFrom (V tr) s'" by (intro Cons.IH) show ?case proof cases assume Ï: "Ï (Trans s a ou s')" then have V: "V (Trans s a ou s' # tr) = f (Trans s a ou s') # V tr" by auto from Ï vVS_tr Cons.prems step show ?thesis unfolding trn V by (elim ÏE) auto next assume "Â¬Ï (Trans s a ou s')" then have "V (Trans s a ou s' # tr) = V tr" and "friends12 s' = friends12 s" and "UID1 ââ pendingFReqs s' UID2 â· UID1 ââ pendingFReqs s UID2" and "UID2 ââ pendingFReqs s' UID1 â· UID2 ââ pendingFReqs s UID1" using step_friends12_Ï[OF step] step_pendingFReqs_Ï[OF step] by auto with vVS_tr show ?thesis unfolding trn by auto qed qed auto lemma "validFrom istate tr â¹ validValSeqFrom (V tr) istate" using validFrom_validValSeq[of istate] reach.Istate unfolding istate_def friends12_def by auto subsection â¹Unwinding proofâº (* Key lemma: *) lemma eqButUID_step_Î³_out: assumes ss1: "eqButUID s s1" and step: "step s a = (ou,s')" and step1: "step s1 a = (ou1,s1')" and Î³: "Î³ (Trans s a ou s')" and os: "open s â¶ friendIDs s = friendIDs s1" shows "ou = ou1" proof - from Î³ obtain uid where uid: "userOfA a = Some uid â§ uid â UIDs â§ uid â UID1 â§ uid â UID2 â¨ userOfA a = None" using UID1_UID2_UIDs by (cases "userOfA a") auto { fix uid assume "uid ââ friendIDs s UID1 â¨ uid ââ friendIDs s UID2" and "uid â UIDs" with os have "friendIDs s = friendIDs s1" unfolding open_def openByF_def by auto } note fIDs = this { fix uid uid' assume uid: "uid â UID1" "uid â UID2" have "friendIDs s uid = friendIDs s1 uid" (is ?f_eq) and "pendingFReqs s uid = pendingFReqs s1 uid" (is ?pFR_eq) and "uid ââ friendIDs s uid' â· uid ââ friendIDs s1 uid'" (is ?f_iff) and "uid ââ pendingFReqs s uid' â· uid ââ pendingFReqs s1 uid'" (is ?pFR_iff) and "friendReq s uid uid' = friendReq s1 uid uid'" (is ?FR_eq) and "friendReq s uid' uid = friendReq s1 uid' uid" (is ?FR_eq') proof - show ?f_eq ?pFR_eq using uid ss1 UID1_UID2_UIDs unfolding eqButUID_def by (auto intro!: eqButUIDf_not_UID) show ?f_iff ?pFR_iff using uid ss1 UID1_UID2_UIDs unfolding eqButUID_def by (auto intro!: eqButUIDf_not_UID') from uid have "Â¬ (uid,uid') â {(UID1,UID2), (UID2,UID1)}" by auto then show ?FR_eq ?FR_eq' using ss1 UID1_UID2_UIDs unfolding eqButUID_def by (auto intro!: eqButUID12_not_UID) qed } note simps = this eqButUID_def r_defs s_defs c_defs l_defs u_defs d_defs note facts = ss1 step step1 uid show ?thesis proof (cases a) case (Ract ra) then show ?thesis using facts apply (cases ra) by (auto simp add: simps) next case (Sact sa) then show ?thesis using facts by (cases sa) (auto simp add: simps) next case (Cact ca) then show ?thesis using facts by (cases ca) (auto simp add: simps) next case (Lact la) then show ?thesis using facts proof (cases la) case (lFriends uid p uid') with Î³ have uid: "uid â UIDs" using Lact by auto then have uid_uid': "uid ââ friendIDs s uid' â· uid ââ friendIDs s1 uid'" using ss1 UID1_UID2_UIDs unfolding eqButUID_def by (intro eqButUIDf_not_UID') auto show ?thesis proof (cases "(uid' = UID1 â¨ uid' = UID2) â§ uid ââ friendIDs s uid'") case True with uid have "friendIDs s = friendIDs s1" by (intro fIDs) auto then show ?thesis using lFriends facts Lact by (auto simp: simps) next case False then show ?thesis using lFriends facts Lact simps(1) uid_uid' by (auto simp: simps) qed next case (lPosts uid p) then have o: "âpid. owner s pid = owner s1 pid" and n: "âpid. post s pid = post s1 pid" and pids: "postIDs s = postIDs s1" and viss: "vis s = vis s1" and fu: "âuid'. uid ââ friendIDs s uid' â· uid ââ friendIDs s1 uid'" and e: "e_listPosts s uid p â· e_listPosts s1 uid p" using ss1 uid Lact unfolding eqButUID_def l_defs by (auto simp add: simps(3)) have "listPosts s uid p = listPosts s1 uid p" unfolding listPosts_def o n pids fu viss .. with e show ?thesis using Lact lPosts step step1 by auto qed (auto simp add: simps) next case (Uact ua) then show ?thesis using facts by (cases ua) (auto simp add: simps) next case (Dact da) then show ?thesis using facts by (cases da) (auto simp add: simps) qed qed (* helper *) lemma produce_FRVal: assumes rs: "reach s" and IDs: "IDsOK s [UID1, UID2] []" and vVS: "validValSeqFrom (FRVal u req # vl) s" obtains a uid uid' s' where "step s a = (outOK, s')" and "a = Cact (cFriendReq uid (pass s uid) uid' req)" and "uid = UID1 â§ uid' = UID2 â¨ uid = UID2 â§ uid' = UID1" and "Ï (Trans s a outOK s')" and "f (Trans s a outOK s') = FRVal u req" and "validValSeqFrom vl s'" proof (cases u) case U1 then have "step s (Cact (cFriendReq UID1 (pass s UID1) UID2 req)) = (outOK, createFriendReq s UID1 (pass s UID1) UID2 req)" and "Â¬friends12 (createFriendReq s UID1 (pass s UID1) UID2 req)" using IDs vVS reach_friendIDs_symmetric[OF rs] by (auto simp: c_defs friends12_def) then show thesis using U1 vVS UID1_UID2 by (intro that[of _ _ UID1 UID2]) (auto simp: c_defs) next case U2 then have "step s (Cact (cFriendReq UID2 (pass s UID2) UID1 req)) = (outOK, createFriendReq s UID2 (pass s UID2) UID1 req)" and "Â¬friends12 (createFriendReq s UID2 (pass s UID2) UID1 req)" using IDs vVS reach_friendIDs_symmetric[OF rs] by (auto simp: c_defs friends12_def) then show thesis using U2 vVS UID1_UID2 by (intro that[of _ _ UID2 UID1]) (auto simp: c_defs) qed (* helper *) lemma toggle_friends12_True: assumes rs: "reach s" and IDs: "IDsOK s [UID1, UID2] []" and nf12: "Â¬friends12 s" and vVS: "validValSeqFrom (FVal True # vl) s" obtains a uid uid' s' where "step s a = (outOK, s')" and "a = Cact (cFriend uid (pass s uid) uid')" and "s' = createFriend s UID1 (pass s UID1) UID2" and "uid = UID1 â§ uid' = UID2 â¨ uid = UID2 â§ uid' = UID1" and "friends12 s'" and "eqButUID s s'" and "Ï (Trans s a outOK s')" and "f (Trans s a outOK s') = FVal True" and "Â¬Î³ (Trans s a outOK s')" and "validValSeqFrom vl s'" proof - from vVS have "UID1 ââ pendingFReqs s UID2 â¨ UID2 ââ pendingFReqs s UID1" by auto then show thesis proof assume pFR: "UID1 ââ pendingFReqs s UID2" let ?a = "Cact (cFriend UID2 (pass s UID2) UID1)" let ?s' = "createFriend s UID1 (pass s UID1) UID2" let ?trn = "Trans s ?a outOK ?s'" have step: "step s ?a = (outOK, ?s')" using IDs pFR UID1_UID2 unfolding createFriend_sym[of "s" "UID1" "pass s UID1" "UID2" "pass s UID2"] by (auto simp add: c_defs) moreover then have "Ï ?trn" and "f ?trn = FVal True" and "friends12 ?s'" and "UID1 â set (pendingFReqs ?s' UID2)" and "UID2 â set (pendingFReqs ?s' UID1)" using reach_distinct_friends_reqs[OF rs] by (auto simp: c_defs friends12_def) moreover have "Â¬Î³ ?trn" using UID1_UID2_UIDs by auto ultimately show thesis using nf12 rs vVS by (intro that[of "?a" "?s'" UID2 UID1]) (auto intro: Cact_cFriend_step_eqButUID) next assume pFR: "UID2 ââ pendingFReqs s UID1" let ?a = "Cact (cFriend UID1 (pass s UID1) UID2)" let ?s' = "createFriend s UID1 (pass s UID1) UID2" let ?trn = "Trans s ?a outOK ?s'" have step: "step s ?a = (outOK, ?s')" using IDs pFR UID1_UID2 by (auto simp add: c_defs) moreover then have "Ï ?trn" and "f ?trn = FVal True" and "friends12 ?s'" and "UID1 â set (pendingFReqs ?s' UID2)" and "UID2 â set (pendingFReqs ?s' UID1)" using reach_distinct_friends_reqs[OF rs] by (auto simp: c_defs friends12_def) moreover have "Â¬Î³ ?trn" using UID1_UID2_UIDs by auto ultimately show thesis using nf12 rs vVS by (intro that[of "?a" "?s'" UID1 UID2]) (auto intro: Cact_cFriend_step_eqButUID) qed qed (* helper *) lemma toggle_friends12_False: assumes rs: "reach s" and IDs: "IDsOK s [UID1, UID2] []" and f12: "friends12 s" and vVS: "validValSeqFrom (FVal False # vl) s" obtains a s' where "step s a = (outOK, s')" and "a = Dact (dFriend UID1 (pass s UID1) UID2)" and "s' = deleteFriend s UID1 (pass s UID1) UID2" and "Â¬friends12 s'" and "eqButUID s s'" and "Ï (Trans s a outOK s')" and "f (Trans s a outOK s') = FVal False" and "Â¬Î³ (Trans s a outOK s')" and "validValSeqFrom vl s'" proof - let ?a = "Dact (dFriend UID1 (pass s UID1) UID2)" let ?s' = "deleteFriend s UID1 (pass s UID1) UID2" let ?trn = "Trans s ?a outOK ?s'" from vVS have step: "step s ?a = (outOK, ?s')" and "UID1 â set (pendingFReqs ?s' UID2)" "UID2 â set (pendingFReqs ?s' UID1)" using IDs f12 UID1_UID2 by (auto simp add: d_defs friends12_def) moreover then have "Ï ?trn" and "f ?trn = FVal False" and "Â¬friends12 ?s'" by (auto simp: d_defs friends12_def) moreover have "Â¬Î³ ?trn" using UID1_UID2_UIDs by auto ultimately show thesis using f12 rs vVS by (intro that[of ?a ?s']) (auto intro: Dact_dFriend_step_eqButUID) qed lemma toggle_friends12: assumes rs: "reach s" and IDs: "IDsOK s [UID1, UID2] []" and f12: "friends12 s â fv" and vVS: "validValSeqFrom (FVal fv # vl) s" obtains a s' where "step s a = (outOK, s')" and "friends12 s' = fv" and "eqButUID s s'" and "Ï (Trans s a outOK s')" and "f (Trans s a outOK s') = FVal fv" and "Â¬Î³ (Trans s a outOK s')" and "validValSeqFrom vl s'" proof (cases "friends12 s") case True moreover then have "UID1 â set (pendingFReqs s UID2)" "UID2 â set (pendingFReqs s UID1)" and "fv = False" and vVS: "validValSeqFrom (FVal False # vl) s" using vVS f12 unfolding friends12_def by auto moreover then have "UID1 â set (pendingFReqs (deleteFriend s UID1 (pass s UID1) UID2) UID2)" "UID2 â set (pendingFReqs (deleteFriend s UID1 (pass s UID1) UID2) UID1)" by (auto simp: d_defs) ultimately show thesis using assms by (elim toggle_friends12_False, blast, blast, blast) (elim that, blast+) next case False moreover then have "fv = True" and vVS: "validValSeqFrom (FVal True # vl) s" using vVS f12 by auto moreover have "UID1 â set (pendingFReqs (createFriend s UID1 (pass s UID1) UID2) UID2)" "UID2 â set (pendingFReqs (createFriend s UID1 (pass s UID1) UID2) UID1)" using reach_distinct_friends_reqs[OF rs] by (auto simp: c_defs) ultimately show thesis using assms by (elim toggle_friends12_True, blast, blast, blast) (elim that, blast+) qed (* helper *) lemma BO_cases: assumes "BO vl vl1" obtains (Nil) "vl = []" and "vl1 = []" | (FVal) fv vl' vl1' where "vl = FVal fv # vl'" and "vl1 = FVal fv # vl1'" and "BO vl' vl1'" | (OVal) vl' vl1' where "vl = OVal False # vl'" and "vl1 = OVal False # vl1'" and "BC vl' vl1'" using assms proof (cases rule: BO.cases) case (BO_FVal fs) then show thesis by (cases fs) (auto intro: Nil FVal) next case (BO_BC vl'' vl1'' fs) then show thesis by (cases fs) (auto intro: FVal OVal) qed (* helper *) lemma BC_cases: assumes "BC vl vl1" obtains (Nil) "vl = []" and "vl1 = []" | (FVal) fv fs where "vl = FVal fv # map FVal fs" and "vl1 = []" | (FVal1) fv fs fs1 where "vl = map FVal fs" and "vl1 = FVal fv # map FVal fs1" | (BO_FVal) fv fv' fs vl' vl1' where "vl = FVal fv # map FVal fs @ FVal fv' # OVal True # vl'" and "vl1 = FVal fv' # OVal True # vl1'" and "BO vl' vl1'" | (BO_FVal1) fv fv' fs fs1 vl' vl1' where "vl = map FVal fs @ FVal fv' # OVal True # vl'" and "vl1 = FVal fv # map FVal fs1 @ FVal fv' # OVal True # vl1'" and "BO vl' vl1'" | (FVal_BO) fv vl' vl1' where "vl = FVal fv # OVal True # vl'" and "vl1 = FVal fv # OVal True # vl1'" and "BO vl' vl1'" | (OVal) vl' vl1' where "vl = OVal True # vl'" and "vl1 = OVal True # vl1'" and "BO vl' vl1'" using assms proof (cases rule: BC.cases) case (BC_FVal fs fs1) then show ?thesis proof (induction fs1) case Nil then show ?case by (induction fs) (auto intro: that(1,2)) next case (Cons fv fs1') then show ?case by (intro that(3)) auto qed next case (BC_BO vl' vl1' fs fs1) then show ?thesis proof (cases fs1 rule: rev_cases) case Nil then show ?thesis using BC_BO by (intro that(7)) auto next case (snoc fs1' fv') moreover then obtain fs' where "fs = fs' ## fv'" using BC_BO by (induction fs rule: rev_induct) auto ultimately show ?thesis using BC_BO proof (induction fs1') case Nil then show ?thesis proof (induction fs') case Nil then show ?thesis by (intro that(6)) auto next case (Cons fv'' fs'') then show ?thesis by (intro that(4)) auto qed next case (Cons fv'' fs1'') then show ?thesis by (intro that(5)) auto qed qed qed definition Î0 :: "state â value list â state â value list â bool" where "Î0 s vl s1 vl1 â¡ s = s1 â§ B vl vl1 â§ open s â§ (Â¬IDsOK s [UID1, UID2] [])" definition Î1 :: "state â value list â state â value list â bool" where "Î1 s vl s1 vl1 â¡ eqButUID s s1 â§ friendIDs s = friendIDs s1 â§ open s â§ BO (filter (Not o isFRVal) vl) (filter (Not o isFRVal) vl1) â§ validValSeqFrom vl1 s1 â§ IDsOK s1 [UID1, UID2] []" definition Î2 :: "state â value list â state â value list â bool" where "Î2 s vl s1 vl1 â¡ (âfs fs1. eqButUID s s1 â§ Â¬open s â§ validValSeqFrom vl1 s1 â§ filter (Not o isFRVal) vl = map FVal fs â§ filter (Not o isFRVal) vl1 = map FVal fs1)" definition Î3 :: "state â value list â state â value list â bool" where "Î3 s vl s1 vl1 â¡ (âfs fs1 vlr vlr1. eqButUID s s1 â§ Â¬open s â§ BO vlr vlr1 â§ validValSeqFrom vl1 s1 â§ (fs = [] â· fs1 = []) â§ (fs â [] â¶ last fs = last fs1) â§ (fs = [] â¶ friendIDs s = friendIDs s1) â§ filter (Not o isFRVal) vl = map FVal fs @ OVal True # vlr â§ filter (Not o isFRVal) vl1 = map FVal fs1 @ OVal True # vlr1)" lemma Î2_I: assumes "eqButUID s s1" "Â¬open s" "validValSeqFrom vl1 s1" "filter (Not o isFRVal) vl = map FVal fs" "filter (Not o isFRVal) vl1 = map FVal fs1" shows "Î2 s vl s1 vl1" using assms unfolding Î2_def by blast lemma Î3_I: assumes "eqButUID s s1" "Â¬open s" "BO vlr vlr1" "validValSeqFrom vl1 s1" "fs = [] â· fs1 = []" "fs â [] â¶ last fs = last fs1" "fs = [] â¶ friendIDs s = friendIDs s1" "filter (Not o isFRVal) vl = map FVal fs @ OVal True # vlr" "filter (Not o isFRVal) vl1 = map FVal fs1 @ OVal True # vlr1" shows "Î3 s vl s1 vl1" using assms unfolding Î3_def by blast lemma istate_Î0: assumes B: "B vl vl1" shows "Î0 istate vl istate vl1" using assms unfolding Î0_def istate_def B_def open_def openByA_def openByF_def friends12_def by auto lemma unwind_cont_Î0: "unwind_cont Î0 {Î0,Î1,Î2,Î3}" proof(rule, simp) let ?Î = "Î»s vl s1 vl1. Î0 s vl s1 vl1 â¨ Î1 s vl s1 vl1 â¨ Î2 s vl s1 vl1 â¨ Î3 s vl s1 vl1" fix s s1 :: state and vl vl1 :: "value list" assume rsT: "reachNT s" and rs1: "reach s1" and Î0: "Î0 s vl s1 vl1" then have rs: "reach s" and ss1: "s1 = s" and B: "B vl vl1" and os: "open s" and IDs: "Â¬IDsOK s [UID1, UID2] []" using reachNT_reach unfolding Î0_def by auto from IDs have "UID1 â set (pendingFReqs s UID2)" and "Â¬friends12 s" and "UID2 â set (pendingFReqs s UID1)" using reach_IDs_used_IDsOK[OF rs] unfolding friends12_def by auto with B have BO: "BO (filter (Not â isFRVal) vl) (filter (Not â isFRVal) vl1)" and vl_vl1: "vl = [] â¶ vl1 = []" and vl_OVal: "vl â [] â§ hd vl = OVal False â¶ vl1 â [] â§ hd vl1 = OVal False" and vVS: "validValSeqFrom vl1 s" unfolding B_def by (auto simp: istate_def friends12_def) show "iaction ?Î s vl s1 vl1 â¨ ((vl = [] â¶ vl1 = []) â§ reaction ?Î s vl s1 vl1)" (is "?iact â¨ (_ â§ ?react)") proof - have ?react proof fix a :: act and ou :: out and s' :: state and vl' let ?trn = "Trans s a ou s'" assume step: "step s a = (ou, s')" and T: "Â¬ T ?trn" and c: "consume ?trn vl vl'" show "match ?Î s s1 vl1 a ou s' vl' â¨ ignore ?Î s s1 vl1 a ou s' vl'" (is "?match â¨ ?ignore") proof cases assume Ï: "Ï ?trn" then obtain uid p uid' p' where a: "a = Cact (cUser uid p uid' p')" "Â¬openByA s'" "Â¬openByF s'" "ou = outOK" "f ?trn = OVal False" "friends12 s' = friends12 s" "UID1 ââ pendingFReqs s' UID2 â· UID1 ââ pendingFReqs s UID2" "UID2 ââ pendingFReqs s' UID1 â· UID2 ââ pendingFReqs s UID1" using step rs IDs by (elim ÏE) (auto simp: openByA_def) with c Ï have vl: "vl = OVal False # vl'" unfolding consume_def by auto with vl_OVal obtain vl1' where vl1: "vl1 = OVal False # vl1'" by (cases vl1) auto from BO vl vl1 have BC': "BC (filter (Not â isFRVal) vl') (filter (Not â isFRVal) vl1')" by (cases rule: BO_cases) auto then have "Î2 s' vl' s' vl1' â¨ Î3 s' vl' s' vl1'" using vVS a unfolding vl1 proof (cases rule: BC.cases) case BC_FVal then show ?thesis using vVS a unfolding vl1 by (intro disjI1 Î2_I) (auto simp: open_def) next case BC_BO then show ?thesis using vVS a unfolding vl1 by (intro disjI2 Î3_I) (auto simp: open_def) qed then have ?match using step a Ï unfolding ss1 vl1 by (intro matchI[of s a ou s']) (auto simp: consume_def) then show ?thesis .. next assume nÏ: "Â¬Ï ?trn" then have s': "open s'" "friends12 s' = friends12 s" "UID1 ââ pendingFReqs s' UID2 â· UID1 ââ pendingFReqs s UID2" "UID2 ââ pendingFReqs s' UID1 â· UID2 ââ pendingFReqs s UID1" using os step_open_Ï[OF step] step_friends12_Ï[OF step] step_pendingFReqs_Ï[OF step] by auto moreover have "vl' = vl" using nÏ c by (auto simp: consume_def) ultimately have "Î0 s' vl' s' vl1 â¨ Î1 s' vl' s' vl1" using vVS B BO unfolding Î0_def Î1_def by (cases "IDsOK s' [UID1, UID2] []") auto then have ?match using step c nÏ unfolding ss1 by (intro matchI[of s a ou s']) (auto simp: consume_def) then show ?thesis .. qed qed then show ?thesis using vl_vl1 by auto qed qed lemma unwind_cont_Î1: "unwind_cont Î1 {Î1,Î2,Î3}" proof(rule, simp) let ?Î = "Î»s vl s1 vl1. Î1 s vl s1 vl1 â¨ Î2 s vl s1 vl1 â¨ Î3 s vl s1 vl1" fix s s1 :: state and vl vl1 :: "value list" assume rsT: "reachNT s" and rs1: "reach s1" and Î1: "Î1 s vl s1 vl1" then have rs: "reach s" and ss1: "eqButUID s s1" and fIDs: "friendIDs s = friendIDs s1" and os: "open s" and BO: "BO (filter (Not o isFRVal) vl) (filter (Not o isFRVal) vl1)" and vVS1: "validValSeq vl1 (friends12 s1) (UID1 ââ pendingFReqs s1 UID2) (UID2 ââ pendingFReqs s1 UID1)" (is "?vVS vl1 s1") and IDs1: "IDsOK s1 [UID1, UID2] []" using reachNT_reach unfolding Î1_def by auto show "iaction ?Î s vl s1 vl1 â¨ ((vl = [] â¶ vl1 = []) â§ reaction ?Î s vl s1 vl1)" (is "?iact â¨ (_ â§ ?react)") proof cases assume "âu req vl1'. vl1 = FRVal u req # vl1'" then obtain u req vl1' where vl1: "vl1 = FRVal u req # vl1'" by auto obtain a uid uid' s1' where step1: "step s1 a = (outOK, s1')" and "Ï (Trans s1 a outOK s1')" and a: "a = Cact (cFriendReq uid (pass s1 uid) uid' req)" and uid: "uid = UID1 â§ uid' = UID2 â¨ uid = UID2 â§ uid' = UID1" and "f (Trans s1 a outOK s1') = FRVal u req" and "?vVS vl1' s1'" using rs1 IDs1 vVS1 UID1_UID2_UIDs unfolding vl1 by (blast intro: produce_FRVal) moreover then have "Â¬Î³ (Trans s1 a outOK s1')" using UID1_UID2_UIDs by auto moreover have "eqButUID s1 s1'" using step1 a uid by (auto intro: Cact_cFriendReq_step_eqButUID) moreover have "friendIDs s1' = friendIDs s1" and "IDsOK s1' [UID1, UID2] []" using step1 a uid by (auto simp: c_defs) ultimately have "?iact" using ss1 fIDs os BO unfolding vl1 by (intro iactionI[of s1 a "outOK" s1']) (auto simp: consume_def Î1_def intro: eqButUID_trans) then show ?thesis .. next assume nFRVal1: "Â¬ (âu req vl1'. vl1 = FRVal u req # vl1')" have ?react proof fix a :: act and ou :: out and s' :: state and vl' let ?trn = "Trans s a ou s'" assume step: "step s a = (ou, s')" and T: "Â¬ T ?trn" and c: "consume ?trn vl vl'" show "match ?Î s s1 vl1 a ou s' vl' â¨ ignore ?Î s s1 vl1 a ou s' vl'" (is "?match â¨ ?ignore") proof cases assume Ï: "Ï ?trn" then have vl: "vl = f ?trn # vl'" using c by (auto simp: consume_def) from BO show ?thesis proof (cases "f ?trn") case (FVal fv) with BO obtain vl1' where vl1: "vl1 = f ?trn # vl1'" using BO_Nil_iff[OF BO] FVal vl nFRVal1 by (cases rule: BO_cases; cases vl1; cases "hd vl1") auto with BO have BO': "BO (filter (Not o isFRVal) vl') (filter (Not o isFRVal) vl1')" using FVal vl by (cases rule: BO_cases) auto from fIDs have f12: "friends12 s = friends12 s1" unfolding friends12_def by auto have ?match using Ï step rs FVal proof (cases rule: ÏE) case (Friend uid p uid') then have IDs1: "IDsOK s1 [UID1, UID2] []" using ss1 unfolding eqButUID_def by auto let ?s1' = "createFriend s1 UID1 (pass s1 UID1) UID2" have s': "s' = createFriend s UID1 p UID2" using Friend step by (auto simp: createFriend_sym) have ss': "eqButUID s s'" using rs step Friend by (auto intro: Cact_cFriend_step_eqButUID) moreover then have os': "open s'" using os eqButUID_open_eq by auto moreover obtain a1 uid1 uid1' p1 where "step s1 a1 = (outOK, ?s1')" "friends12 ?s1'" "a1 = Cact (cFriend uid1 p1 uid1')" "uid1 = UID1 â§ uid1' = UID2 â¨ uid1 = UID2 â§ uid1' = UID1" "Ï (Trans s1 a1 outOK ?s1')" "f (Trans s1 a1 outOK ?s1') = FVal True" "eqButUID s1 ?s1'" "?vVS vl1' ?s1'" using rs1 IDs1 Friend vVS1 unfolding vl1 f12 Friend(3) by (elim toggle_friends12_True) blast+ moreover then have "IDsOK ?s1' [UID1, UID2] []" by (auto simp: c_defs) moreover have "friendIDs s' = friendIDs ?s1'" using Friend(6) f12 unfolding s' by (intro eqButUID_createFriend12_friendIDs_eq[OF ss1 rs rs1]) auto ultimately show ?match using ss1 BO' Friend UID1_UID2_UIDs unfolding vl1 Î1_def by (intro matchI[of s1 a1 "outOK" ?s1']) (auto simp: consume_def intro: eqButUID_trans eqButUID_sym) next case (Unfriend uid p uid') then have IDs1: "IDsOK s1 [UID1, UID2] []" using ss1 unfolding eqButUID_def by auto let ?s1' = "deleteFriend s1 UID1 (pass s1 UID1) UID2" have s': "s' = deleteFriend s UID1 p UID2" using Unfriend step by (auto simp: deleteFriend_sym) have ss': "eqButUID s s'" using rs step Unfriend by (auto intro: Dact_dFriend_step_eqButUID) moreover then have os': "open s'" using os eqButUID_open_eq by auto moreover obtain a1 uid1 uid1' p1 where "step s1 a1 = (outOK, ?s1')" "Â¬friends12 ?s1'" "a1 = Dact (dFriend uid1 p1 uid1')" "uid1 = UID1 â§ uid1' = UID2 â¨ uid1 = UID2 â§ uid1' = UID1" "Ï (Trans s1 a1 outOK ?s1')" "f (Trans s1 a1 outOK ?s1') = FVal False" "eqButUID s1 ?s1'" "?vVS vl1' ?s1'" using rs1 IDs1 Unfriend vVS1 unfolding vl1 f12 Unfriend(3) by (elim toggle_friends12_False) blast+ moreover have "friendIDs s' = friendIDs ?s1'" "IDsOK ?s1' [UID1, UID2] []" using fIDs IDs1 unfolding s' by (auto simp: d_defs) ultimately show ?match using ss1 BO' Unfriend UID1_UID2_UIDs unfolding vl1 Î1_def by (intro matchI[of s1 a1 "outOK" ?s1']) (auto simp: consume_def intro: eqButUID_trans eqButUID_sym) qed auto then show ?thesis .. next case (OVal ov) with BO obtain vl1' where vl1': "vl1 = OVal False # vl1'" using BO_Nil_iff[OF BO] OVal vl nFRVal1 by (cases rule: BO_cases; cases vl1; cases "hd vl1") auto with BO have BC': "BC (filter (Not o isFRVal) vl') (filter (Not o isFRVal) vl1')" using OVal vl by (cases rule: BO_cases) auto from BO vl OVal have "f ?trn = OVal False" by (cases rule: BO_cases) auto with Ï step rs have ?match proof (cases rule: ÏE) case (CloseF uid p uid') let ?s1' = "deleteFriend s1 uid p uid'" let ?trn1 = "Trans s1 a outOK ?s1'" have s': "s' = deleteFriend s uid p uid'" using CloseF step by auto have step1: "step s1 a = (outOK, ?s1')" and pFR1': "pendingFReqs ?s1' = pendingFReqs s1" using CloseF step ss1 fIDs unfolding eqButUID_def by (auto simp: d_defs) have s's1': "eqButUID s' ?s1'" using eqButUID_step[OF ss1 step step1 rs rs1] . moreover have os': "Â¬open s'" using CloseF os unfolding open_def by auto moreover have fIDs': "friendIDs s' = friendIDs ?s1'" using fIDs unfolding s' by (auto simp: d_defs) moreover have f12s1: "friends12 s1 = friends12 ?s1'" using CloseF(2) UID1_UID2_UIDs unfolding friends12_def d_defs by auto from BC' have "Î2 s' vl' ?s1' vl1' â¨ Î3 s' vl' ?s1' vl1'" proof (cases rule: BC.cases) case (BC_FVal fs fs1) then show ?thesis using vVS1 os' fIDs' f12s1 s's1' pFR1' unfolding Î2_def vl1' by auto next case (BC_BO vlr vlr1 fs fs1) then have "Î3 s' vl' ?s1' vl1'" using s's1' os' vVS1 f12s1 fIDs' pFR1' unfolding vl1' by (intro Î3_I[of _ _ _ _ _ fs fs1]) auto then show ?thesis .. qed moreover have "open s1" "Â¬open ?s1'" using ss1 os s's1' os' by (auto simp: eqButUID_open_eq) moreover then have "Ï ?trn1" unfolding CloseF by auto ultimately show ?match using step1 vl1' CloseF UID1_UID2 UID1_UID2_UIDs by (intro matchI[of s1 a outOK ?s1' vl1 vl1']) (auto simp: consume_def) next case (CloseA uid p uid' p') let ?s1' = "createUser s1 uid p uid' p'" let ?trn1 = "Trans s1 a outOK ?s1'" have s': "s' = createUser s uid p uid' p'" using CloseA step by auto have step1: "step s1 a = (outOK, ?s1')" and pFR1': "pendingFReqs ?s1' = pendingFReqs s1" using CloseA step ss1 unfolding eqButUID_def by (auto simp: c_defs) have s's1': "eqButUID s' ?s1'" using eqButUID_step[OF ss1 step step1 rs rs1] . moreover have os': "Â¬open s'" using CloseA os unfolding open_def by auto moreover have fIDs': "friendIDs s' = friendIDs ?s1'" using fIDs unfolding s' by (auto simp: c_defs) moreover have f12s1: "friends12 s1 = friends12 ?s1'" unfolding friends12_def by (auto simp: c_defs) from BC' have "Î2 s' vl' ?s1' vl1' â¨ Î3 s' vl' ?s1' vl1'" proof (cases rule: BC.cases) case (BC_FVal fs fs1) then show ?thesis using vVS1 os' fIDs' f12s1 s's1' pFR1' unfolding Î2_def vl1' by auto next case (BC_BO vlr vlr1 fs fs1) then have "Î3 s' vl' ?s1' vl1'" using s's1' os' vVS1 f12s1 fIDs' pFR1' unfolding vl1' by (intro Î3_I[of _ _ _ _ _ fs fs1]) auto then show ?thesis .. qed moreover have "open s1" "Â¬open ?s1'" using ss1 os s's1' os' by (auto simp: eqButUID_open_eq) moreover then have "Ï ?trn1" unfolding CloseA by auto ultimately show ?match using step1 vl1' CloseA UID1_UID2 UID1_UID2_UIDs by (intro matchI[of s1 a outOK ?s1' vl1 vl1']) (auto simp: consume_def) qed auto then show ?thesis .. next case (FRVal u req) obtain p where a: "(a = Cact (cFriendReq UID1 p UID2 req) â§ UID1 ââ pendingFReqs s' UID2 â§ UID1 â set (pendingFReqs s UID2) â§ (UID2 ââ pendingFReqs s' UID1 â· UID2 ââ pendingFReqs s UID1)) â¨ (a = Cact (cFriendReq UID2 p UID1 req) â§ UID2 ââ pendingFReqs s' UID1 â§ UID2 â set (pendingFReqs s UID1) â§ (UID1 ââ pendingFReqs s' UID2 â· UID1 ââ pendingFReqs s UID2))" "ou = outOK" "Â¬friends12 s" "Â¬friends12 s'" "open s' = open s" using Ï step rs FRVal by (cases rule: ÏE) fastforce+ then have fIDs': "friendIDs s' = friendIDs s" using step by (auto simp: c_defs) have "eqButUID s s'" using a step by (auto intro: Cact_cFriendReq_step_eqButUID) then have "Î1 s' vl' s1 vl1" unfolding Î1_def using ss1 fIDs' fIDs os a(5) vVS1 IDs1 BO vl FRVal by (auto intro: eqButUID_trans eqButUID_sym) moreover from Ï step rs a have "Â¬Î³ (Trans s a ou s')" using UID1_UID2_UIDs by auto ultimately have ?ignore by (intro ignoreI) auto then show ?thesis .. qed next assume nÏ: "Â¬Ï ?trn" then have os': "open s = open s'" and f12s': "friends12 s = friends12 s'" using step_open_Ï[OF step] step_friends12_Ï[OF step] by auto have vl': "vl' = vl" using nÏ c by (auto simp: consume_def) show ?thesis proof (cases "âreq. a â Cact (cFriend UID1 (pass s UID1) UID2) â§ a â Cact (cFriend UID2 (pass s UID2) UID1) â§ a â Cact (cFriendReq UID2 (pass s UID2) UID1 req) â§ a â Cact (cFriendReq UID1 (pass s UID1) UID2 req) â§ a â Dact (dFriend UID1 (pass s UID1) UID2) â§ a â Dact (dFriend UID2 (pass s UID2) UID1)") case True obtain ou1 s1' where step1: "step s1 a = (ou1, s1')" by (cases "step s1 a") auto let ?trn1 = "Trans s1 a ou1 s1'" have fIDs': "friendIDs s' = friendIDs s1'" using True by (intro eqButUID_step_friendIDs_eq[OF ss1 rs rs1 step step1 _ fIDs]) auto from True nÏ have nÏ': "Â¬Ï ?trn1" using eqButUID_step_Ï[OF ss1 rs rs1 step step1] by auto then have f12s1': "friends12 s1 = friends12 s1'" and pFRs': "UID1 ââ pendingFReqs s1 UID2 â· UID1 ââ pendingFReqs s1' UID2" "UID2 ââ pendingFReqs s1 UID1 â· UID2 ââ pendingFReqs s1' UID1" using step_friends12_Ï[OF step1] step_pendingFReqs_Ï[OF step1] by auto have "eqButUID s' s1'" using eqButUID_step[OF ss1 step step1 rs rs1] . then have "Î1 s' vl' s1' vl1" using os fIDs' vVS1 BO IDsOK_mono[OF step1 IDs1] unfolding Î1_def os' f12s1' pFRs' vl' by auto then have ?match using step1 nÏ' fIDs eqButUID_step_Î³_out[OF ss1 step step1] by (intro matchI[of s1 a ou1 s1' vl1 vl1]) (auto simp: consume_def) then show "?match â¨ ?ignore" .. next case False with nÏ have "ou â outOK" by auto then have "s' = s" using step False by auto then have ?ignore using Î1 False UID1_UID2_UIDs unfolding vl' by (intro ignoreI) auto then show "?match â¨ ?ignore" .. qed qed qed moreover have "vl = [] â¶ vl1 = []" proof assume "vl = []" with BO have "filter (Not â isFRVal) vl1 = []" using BO_Nil_iff[OF BO] by auto with nFRVal1 show "vl1 = []" by (cases vl1; cases "hd vl1") auto qed ultimately show ?thesis by auto qed qed lemma unwind_cont_Î2: "unwind_cont Î2 {Î2, Î1}" proof(rule, simp) let ?Î = "Î»s vl s1 vl1. Î2 s vl s1 vl1 â¨ Î1 s vl s1 vl1" fix s s1 :: state and vl vl1 :: "value list" assume rsT: "reachNT s" and rs1: "reach s1" and 2: "Î2 s vl s1 vl1" from rsT have rs: "reach s" by (intro reachNT_reach) from 2 obtain fs fs1 where ss1: "eqButUID s s1" and os: "Â¬open s" and vVS1: "validValSeqFrom vl1 s1" and fs: "filter (Not o isFRVal) vl = map FVal fs" and fs1: "filter (Not o isFRVal) vl1 = map FVal fs1" unfolding Î2_def by auto from os have IDs: "IDsOK s [UID1, UID2] []" unfolding open_defs by auto then have IDs1: "IDsOK s1 [UID1, UID2] []" using ss1 unfolding eqButUID_def by auto show "iaction ?Î s vl s1 vl1 â¨ ((vl = [] â¶ vl1 = []) â§ reaction ?Î s vl s1 vl1)" (is "?iact â¨ (_ â§ ?react)") proof cases assume vl1: "vl1 = []" have ?react proof fix a :: act and ou :: out and s' :: state and vl' let ?trn = "Trans s a ou s'" assume step: "step s a = (ou, s')" and T: "Â¬ T ?trn" and c: "consume ?trn vl vl'" show "match ?Î s s1 vl1 a ou s' vl' â¨ ignore ?Î s s1 vl1 a ou s' vl'" (is "?match â¨ ?ignore") proof cases assume Ï: "Ï ?trn" with c have vl: "vl = f ?trn # vl'" by (auto simp: consume_def) with fs have ?ignore proof (cases "f ?trn") case (FRVal u req) obtain p where a: "(a = Cact (cFriendReq UID1 p UID2 req) â§ UID1 ââ pendingFReqs s' UID2 â§ UID1 â set (pendingFReqs s UID2) â§ (UID2 ââ pendingFReqs s' UID1 â· UID2 ââ pendingFReqs s UID1)) â¨ (a = Cact (cFriendReq UID2 p UID1 req) â§ UID2 ââ pendingFReqs s' UID1 â§ UID2 â set (pendingFReqs s UID1) â§ (UID1 ââ pendingFReqs s' UID2 â· UID1 ââ pendingFReqs s UID2))" "ou = outOK" "Â¬friends12 s" "Â¬friends12 s'" "open s' = open s" using Ï step rs FRVal by (cases rule: ÏE) fastforce+ then have fIDs': "friendIDs s' = friendIDs s" using step by (auto simp: c_defs) have "eqButUID s s'" using a step by (auto intro: Cact_cFriendReq_step_eqButUID) then have "Î2 s' vl' s1 vl1" unfolding Î2_def using ss1 os a(5) vVS1 vl fs fs1 by (auto intro: eqButUID_trans eqButUID_sym) moreover from Ï step rs a have "Â¬Î³ (Trans s a ou s')" using UID1_UID2_UIDs by auto ultimately show ?ignore by (intro ignoreI) auto next case (FVal fv) with fs vl obtain fs' where fs': "fs = fv # fs'" by (cases fs) auto from Ï step rs FVal have ss': "eqButUID s s'" by (elim ÏE) (auto intro: Cact_cFriend_step_eqButUID Dact_dFriend_step_eqButUID) then have "Â¬open s'" using os by (auto simp: eqButUID_open_eq) moreover have "eqButUID s' s1" using ss1 ss' by (auto intro: eqButUID_sym eqButUID_trans) ultimately have "Î2 s' vl' s1 vl1" using vVS1 fs' fs unfolding Î2_def vl vl1 FVal by auto moreover have "Â¬Î³ ?trn" using Ï step rs FVal UID1_UID2_UIDs by (elim ÏE) auto ultimately show ?ignore by (intro ignoreI) auto qed auto then show ?thesis .. next assume nÏ: "Â¬Ï ?trn" then have os': "open s = open s'" and f12s': "friends12 s = friends12 s'" using step_open_Ï[OF step] step_friends12_Ï[OF step] by auto have vl': "vl' = vl" using nÏ c by (auto simp: consume_def) show ?thesis proof (cases "âreq. a â Cact (cFriend UID1 (pass s UID1) UID2) â§ a â Cact (cFriend UID2 (pass s UID2) UID1) â§ a â Cact (cFriendReq UID2 (pass s UID2) UID1 req) â§ a â Cact (cFriendReq UID1 (pass s UID1) UID2 req) â§ a â Dact (dFriend UID1 (pass s UID1) UID2) â§ a â Dact (dFriend UID2 (pass s UID2) UID1)") case True obtain ou1 s1' where step1: "step s1 a = (ou1, s1')" by (cases "step s1 a") auto let ?trn1 = "Trans s1 a ou1 s1'" from True nÏ have nÏ': "Â¬Ï ?trn1" using eqButUID_step_Ï[OF ss1 rs rs1 step step1] by auto then have f12s1': "friends12 s1 = friends12 s1'" and pFRs': "UID1 ââ pendingFReqs s1 UID2 â· UID1 ââ pendingFReqs s1' UID2" "UID2 ââ pendingFReqs s1 UID1 â· UID2 ââ pendingFReqs s1' UID1" using step_friends12_Ï[OF step1] step_pendingFReqs_Ï[OF step1] by auto have "eqButUID s' s1'" using eqButUID_step[OF ss1 step step1 rs rs1] . then have "Î2 s' vl' s1' vl1" using os vVS1 fs fs1 unfolding Î2_def os' f12s1' pFRs' vl' by auto then have ?match using step1 nÏ' os eqButUID_step_Î³_out[OF ss1 step step1] by (intro matchI[of s1 a ou1 s1' vl1 vl1]) (auto simp: consume_def) then show "?match â¨ ?ignore" .. next case False with nÏ have "ou â outOK" by auto then have "s' = s" using step False by auto then have ?ignore using 2 False UID1_UID2_UIDs unfolding vl' by (intro ignoreI) auto then show "?match â¨ ?ignore" .. qed qed qed then show ?thesis using vl1 by auto next assume "vl1 â []" then obtain v vl1' where vl1: "vl1 = v # vl1'" by (cases vl1) auto with fs1 have ?iact proof (cases v) case (FRVal u req) obtain a uid uid' s1' where step1: "step s1 a = (outOK, s1')" and "Ï (Trans s1 a outOK s1')" and a: "a = Cact (cFriendReq uid (pass s1 uid) uid' req)" and uid: "uid = UID1 â§ uid' = UID2 â¨ uid = UID2 â§ uid' = UID1" and "f (Trans s1 a outOK s1') = FRVal u req" and vVS1': "validValSeqFrom vl1' s1'" using rs1 IDs1 vVS1 UID1_UID2_UIDs unfolding vl1 FRVal by (blast intro: produce_FRVal) moreover then have "Â¬Î³ (Trans s1 a outOK s1')" using UID1_UID2_UIDs by auto moreover have "eqButUID s1 s1'" using step1 a uid by (auto intro: Cact_cFriendReq_step_eqButUID) moreover then have "Î2 s vl s1' vl1'" using ss1 os vVS1' fs fs1 unfolding vl1 FRVal by (intro Î2_I[of s s1' vl1' vl fs fs1]) (auto intro: eqButUID_trans) ultimately show "?iact" using ss1 os unfolding vl1 FRVal by (intro iactionI[of s1 a "outOK" s1']) (auto simp: consume_def intro: eqButUID_trans) next case (FVal fv) then obtain fs1' where fs1': "fs1 = fv # fs1'" using vl1 fs1 by (cases fs1) auto from FVal vVS1 vl1 have f12: "friends12 s1 â fv" and vVS1: "validValSeqFrom (FVal fv # vl1') s1" by auto then show ?iact using rs1 IDs1 vl1 FVal ss1 os fs fs1 fs1' vl1 FVal by (elim toggle_friends12[of s1 fv vl1'], blast, blast, blast) (intro iactionI[of s1 _ _ _ vl1 vl1'], auto simp: consume_def intro: Î2_I[of s _ vl1' vl fs fs1'] eqButUID_trans) qed auto then show ?thesis .. qed qed lemma unwind_cont_Î3: "unwind_cont Î3 {Î3,Î1}" proof(rule, simp) let ?Î = "Î»s vl s1 vl1. Î3 s vl s1 vl1 â¨ Î1 s vl s1 vl1" fix s s1 :: state and vl vl1 :: "value list" assume rsT: "reachNT s" and rs1: "reach s1" and 3: "Î3 s vl s1 vl1" from rsT have rs: "reach s" by (intro reachNT_reach) obtain fs fs1 vlr vlr1 where ss1: "eqButUID s s1" and os: "Â¬open s" and BO: "BO vlr vlr1" and vVS1: "validValSeqFrom vl1 s1" and fs: "filter (Not o isFRVal) vl = map FVal fs @ OVal True # vlr" and fs1: "filter (Not o isFRVal) vl1 = map FVal fs1 @ OVal True # vlr1" and fs_fs1: "fs = [] â· fs1 = []" and last_fs: "fs â [] â¶ last fs = last fs1" and fs_fIDs: "fs = [] â¶ friendIDs s = friendIDs s1" using 3 unfolding Î3_def by auto have BC: "BC (map FVal fs @ OVal True # vlr) (map FVal fs1 @ OVal True # vlr1)" using fs fs1 fs_fs1 last_fs BO by auto from os have IDs: "IDsOK s [UID1, UID2] []" unfolding open_defs by auto then have IDs1: "IDsOK s1 [UID1, UID2] []" using ss1 unfolding eqButUID_def by auto show "iaction ?Î s vl s1 vl1 â¨ ((vl = [] â¶ vl1 = []) â§ reaction ?Î s vl s1 vl1)" (is "?iact â¨ (_ â§ ?react)") proof cases assume "âu req vl1'. vl1 = FRVal u req # vl1'" then obtain u req vl1' where vl1: "vl1 = FRVal u req # vl1'" by auto obtain a uid uid' s1' where step1: "step s1 a = (outOK, s1')" and Ï: "Ï (Trans s1 a outOK s1')" and a: "a = Cact (cFriendReq uid (pass s1 uid) uid' req)" and uid: "uid = UID1 â§ uid' = UID2 â¨ uid = UID2 â§ uid' = UID1" and f: "f (Trans s1 a outOK s1') = FRVal u req" and "validValSeqFrom vl1' s1'" using rs1 IDs1 vVS1 UID1_UID2_UIDs unfolding vl1 by (blast intro: produce_FRVal) moreover have "eqButUID s1 s1'" using step1 a uid by (auto intro: Cact_cFriendReq_step_eqButUID) moreover have "friendIDs s1' = friendIDs s1" and "IDsOK s1' [UID1, UID2] []" using step1 a uid by (auto simp: c_defs) ultimately have "Î3 s vl s1' vl1'" using ss1 os BO fs_fs1 last_fs fs_fIDs fs fs1 unfolding vl1 by (intro Î3_I[of _ _ vlr vlr1 vl1' fs fs1 vl]) (auto simp: consume_def intro: eqButUID_trans) moreover have "Â¬Î³ (Trans s1 a outOK s1')" using a uid UID1_UID2_UIDs by auto ultimately have "?iact" using step1 Ï f unfolding vl1 by (intro iactionI[of s1 a "outOK" s1']) (auto simp: consume_def) then show ?thesis .. next assume nFRVal1: "Â¬(âu req vl1'. vl1 = FRVal u req # vl1')" from BC show ?thesis proof (cases rule: BC_cases) case (BO_FVal fv fv' fs' vl'' vl1'') then have fs': "filter (Not o isFRVal) vl = map FVal (fv # fs' ## fv') @ OVal True # vl''" and fs1': "filter (Not o isFRVal) vl1 = FVal fv' # OVal True # vl1''" using fs fs1 by auto have ?react proof fix a :: act and ou :: out and s' :: state and vl' let ?trn = "Trans s a ou s'" let ?trn1 = "Trans s1 a ou s'" assume step: "step s a = (ou, s')" and T: "Â¬ T ?trn" and c: "consume ?trn vl vl'" show "match ?Î s s1 vl1 a ou s' vl' â¨ ignore ?Î s s1 vl1 a ou s' vl'" (is "?match â¨ ?ignore") proof cases assume Ï: "Ï ?trn" with c have vl: "vl = f ?trn # vl'" by (auto simp: consume_def) with fs' have ?ignore proof (cases "f ?trn") case (FRVal u req) obtain p where a: "(a = Cact (cFriendReq UID1 p UID2 req) â§ UID1 ââ pendingFReqs s' UID2 â§ UID1 â set (pendingFReqs s UID2) â§ (UID2 ââ pendingFReqs s' UID1 â· UID2 ââ pendingFReqs s UID1)) â¨ (a = Cact (cFriendReq UID2 p UID1 req) â§ UID2 ââ pendingFReqs s' UID1 â§ UID2 â set (pendingFReqs s UID1) â§ (UID1 ââ pendingFReqs s' UID2 â· UID1 ââ pendingFReqs s UID2))" "ou = outOK" "Â¬friends12 s" "Â¬friends12 s'" "open s' = open s" using Ï step rs FRVal by (cases rule: ÏE) fastforce+ then have fIDs': "friendIDs s' = friendIDs s" using step by (auto simp: c_defs) have "eqButUID s s'" using a step by (auto intro: Cact_cFriendReq_step_eqButUID) then have "Î3 s' vl' s1 vl1" using ss1 a os BO vVS1 fs_fs1 last_fs fs_fIDs fs fs1 fIDs' vl FRVal by (intro Î3_I[of s' s1 vlr vlr1 vl1 fs fs1 vl']) (auto intro: eqButUID_trans eqButUID_sym) moreover from a have "Â¬Î³ (Trans s a ou s')" using UID1_UID2_UIDs by auto ultimately show ?ignore by (intro ignoreI) auto next case (FVal fv'') with vl fs' have FVal: "f ?trn = FVal fv" and vl': "filter (Not â isFRVal) vl' = map FVal (fs' ## fv') @ OVal True # vl''" by auto from Ï step rs FVal have ss': "eqButUID s s'" by (elim ÏE) (auto intro: Cact_cFriend_step_eqButUID Dact_dFriend_step_eqButUID) then have "Â¬open s'" using os by (auto simp: eqButUID_open_eq) moreover have "eqButUID s' s1" using ss1 ss' by (auto intro: eqButUID_sym eqButUID_trans) ultimately have "Î3 s' vl' s1 vl1" using BO_FVal(3) vVS1 vl' fs1' by (intro Î3_I[of s' s1 vl'' vl1'' vl1 "fs' ## fv'" "[fv']" vl']) auto moreover have "Â¬Î³ ?trn" using Ï step rs FVal UID1_UID2_UIDs by (elim ÏE) auto ultimately show ?ignore by (intro ignoreI) auto qed auto then show ?thesis .. next assume nÏ: "Â¬Ï ?trn" then have os': "open s = open s'" and f12s': "friends12 s = friends12 s'" using step_open_Ï[OF step] step_friends12_Ï[OF step] by auto have vl': "vl' = vl" using nÏ c by (auto simp: consume_def) show ?thesis proof (cases "âreq. a â Cact (cFriend UID1 (pass s UID1) UID2) â§ a â Cact (cFriend UID2 (pass s UID2) UID1) â§ a â Cact (cFriendReq UID2 (pass s UID2) UID1 req) â§ a â Cact (cFriendReq UID1 (pass s UID1) UID2 req) â§ a â Dact (dFriend UID1 (pass s UID1) UID2) â§ a â Dact (dFriend UID2 (pass s UID2) UID1)") case True obtain ou1 s1' where step1: "step s1 a = (ou1, s1')" by (cases "step s1 a") auto let ?trn1 = "Trans s1 a ou1 s1'" from True nÏ have nÏ': "Â¬Ï ?trn1" using eqButUID_step_Ï[OF ss1 rs rs1 step step1] by auto then have f12s1': "friends12 s1 = friends12 s1'" and pFRs': "UID1 ââ pendingFReqs s1 UID2 â· UID1 ââ pendingFReqs s1' UID2" "UID2 ââ pendingFReqs s1 UID1 â· UID2 ââ pendingFReqs s1' UID1" using step_friends12_Ï[OF step1] step_pendingFReqs_Ï[OF step1] by auto have "eqButUID s' s1'" using eqButUID_step[OF ss1 step step1 rs rs1] . thm Î3_I[of s' s1' vl'' vl1'' vl1 "fv # fs' ## fv'" "[fv']" vl'] then have "Î3 s' vl' s1' vl1" using os vVS1 fs' fs1' BO_FVal unfolding os' f12s1' pFRs' vl' by (intro Î3_I[of s' s1' vl'' vl1'' vl1 "fv # fs' ## fv'" "[fv']" vl]) auto then have ?match using step1 nÏ' os eqButUID_step_Î³_out[OF ss1 step step1] by (intro matchI[of s1 a ou1 s1' vl1 vl1]) (auto simp: consume_def) then show "?match â¨ ?ignore" .. next case False with nÏ have "ou â outOK" by auto then have "s' = s" using step False by auto then have ?ignore using 3 False UID1_UID2_UIDs unfolding vl' by (intro ignoreI) auto then show "?match â¨ ?ignore" .. qed qed qed then show ?thesis using fs' by auto next case (BO_FVal1 fv fv' fs' fs1' vl'' vl1'') then have fs': "filter (Not o isFRVal) vl = map FVal (fs' ## fv') @ OVal True # vl''" and fs1': "filter (Not o isFRVal) vl1 = map FVal (fv # fs1' ## fv') @ OVal True # vl1''" using fs fs1 by auto with nFRVal1 obtain vl1' where vl1: "vl1 = FVal fv # vl1'" and vl1': "filter (Not o isFRVal) vl1' = map FVal (fs1' ## fv') @ OVal True # vl1''" by (cases vl1; cases "hd vl1") auto with vVS1 have f12: "friends12 s1 â fv" and vVS1: "validValSeqFrom (FVal fv # vl1') s1" by auto then have ?iact using rs1 IDs1 vl1 ss1 os BO_FVal1(3) fs' vl1' by (elim toggle_friends12[of s1 fv vl1'], blast, blast, blast) (intro iactionI[of s1 _ _ _ vl1 vl1'], auto simp: consume_def intro: Î3_I[of s _ vl'' vl1'' vl1' "fs' ## fv'" "fs1' ## fv'" vl] eqButUID_trans) then show ?thesis .. next case (FVal_BO fv vl'' vl1'') then have fs': "filter (Not o isFRVal) vl = FVal fv # OVal True # vl''" and fs1': "filter (Not o isFRVal) vl1 = FVal fv # OVal True # vl1''" using fs fs1 by auto have ?react proof fix a :: act and ou :: out and s' :: state and vl' let ?trn = "Trans s a ou s'" let ?trn1 = "Trans s1 a ou s'" assume step: "step s a = (ou, s')" and T: "Â¬ T ?trn" and c: "consume ?trn vl vl'" show "match ?Î s s1 vl1 a ou s' vl' â¨ ignore ?Î s s1 vl1 a ou s' vl'" (is "?match â¨ ?ignore") proof cases assume Ï: "Ï ?trn" with c have vl: "vl = f ?trn # vl'" by (auto simp: consume_def) with fs' show ?thesis proof (cases "f ?trn") case (FRVal u req) obtain p where a: "(a = Cact (cFriendReq UID1 p UID2 req) â§ UID1 ââ pendingFReqs s' UID2 â§ UID1 â set (pendingFReqs s UID2) â§ (UID2 ââ pendingFReqs s' UID1 â· UID2 ââ pendingFReqs s UID1)) â¨ (a = Cact (cFriendReq UID2 p UID1 req) â§ UID2 ââ pendingFReqs s' UID1 â§ UID2 â set (pendingFReqs s UID1) â§ (UID1 ââ pendingFReqs s' UID2 â· UID1 ââ pendingFReqs s UID2))" "ou = outOK" "Â¬friends12 s" "Â¬friends12 s'" "open s' = open s" using Ï step rs FRVal by (cases rule: ÏE) fastforce+ then have fIDs': "friendIDs s' = friendIDs s" using step by (auto simp: c_defs) have "eqButUID s s'" using a step by (auto intro: Cact_cFriendReq_step_eqButUID) then have "Î3 s' vl' s1 vl1" using ss1 a os BO vVS1 fs_fs1 last_fs fs_fIDs fs fs1 fIDs' vl FRVal by (intro Î3_I[of s' s1 vlr vlr1 vl1 fs fs1 vl']) (auto intro: eqButUID_trans eqButUID_sym) moreover from a have "Â¬Î³ (Trans s a ou s')" using UID1_UID2_UIDs by auto ultimately have ?ignore by (intro ignoreI) auto then show ?thesis .. next case (FVal fv'') with vl fs' have FVal: "f ?trn = FVal fv" and vl': "filter (Not â isFRVal) vl' = OVal True # vl''" by auto from fs1' nFRVal1 obtain vl1' where vl1: "vl1 = FVal fv # vl1'" and vl1': "filter (Not â isFRVal) vl1' = OVal True # vl1''" by (cases vl1; cases "hd vl1") auto have ?match using Ï step rs FVal proof (cases rule: ÏE) case (Friend uid p uid') then have IDs1: "IDsOK s1 [UID1, UID2] []" and f12s1: "Â¬friends12 s1" and fv: "fv = True" using ss1 vVS1 FVal unfolding eqButUID_def vl1 by auto let ?s1' = "createFriend s1 UID1 (pass s1 UID1) UID2" have s': "s' = createFriend s UID1 p UID2" using Friend step by (auto simp: createFriend_sym) have ss': "eqButUID s s'" using rs step Friend by (auto intro: Cact_cFriend_step_eqButUID) moreover then have os': "Â¬open s'" using os eqButUID_open_eq by auto moreover obtain a1 uid1 uid1' p1 where "step s1 a1 = (outOK, ?s1')" "friends12 ?s1'" "a1 = Cact (cFriend uid1 p1 uid1')" "uid1 = UID1 â§ uid1' = UID2 â¨ uid1 = UID2 â§ uid1' = UID1" "Ï (Trans s1 a1 outOK ?s1')" "f (Trans s1 a1 outOK ?s1') = FVal True" "eqButUID s1 ?s1'" "validValSeqFrom vl1' ?s1'" using rs1 IDs1 Friend vVS1 f12s1 unfolding vl1 FVal by (elim toggle_friends12_True; blast) moreover then have "IDsOK ?s1' [UID1, UID2] []" by (auto simp: c_defs) moreover have "friendIDs s' = friendIDs ?s1'" using Friend(6) f12s1 unfolding s' by (intro eqButUID_createFriend12_friendIDs_eq[OF ss1 rs rs1]) auto ultimately show ?match using ss1 FVal_BO Friend UID1_UID2_UIDs vl' vl1' unfolding vl1 fv by (intro matchI[of s1 a1 "outOK" ?s1']) (auto simp: consume_def intro: eqButUID_trans eqButUID_sym intro!: Î3_I[of s' ?s1' vl'' vl1'' vl1' "[]" "[]" vl']) next case (Unfriend uid p uid') then have IDs1: "IDsOK s1 [UID1, UID2] []" and f12s1: "friends12 s1" and fv: "fv = False" using ss1 vVS1 FVal unfolding eqButUID_def vl1 by auto let ?s1' = "deleteFriend s1 UID1 (pass s1 UID1) UID2" have s': "s' = deleteFriend s UID1 p UID2" using Unfriend step by (auto simp: deleteFriend_sym) have ss': "eqButUID s s'" using rs step Unfriend by (auto intro: Dact_dFriend_step_eqButUID) moreover then have os': "Â¬open s'" using os eqButUID_open_eq by auto moreover obtain a1 uid1 uid1' p1 where "step s1 a1 = (outOK, ?s1')" "Â¬friends12 ?s1'" "a1 = Dact (dFriend uid1 p1 uid1')" "uid1 = UID1 â§ uid1' = UID2 â¨ uid1 = UID2 â§ uid1' = UID1" "Ï (Trans s1 a1 outOK ?s1')" "f (Trans s1 a1 outOK ?s1') = FVal False" "eqButUID s1 ?s1'" "validValSeqFrom vl1' ?s1'" using rs1 IDs1 Unfriend vVS1 f12s1 unfolding vl1 FVal by (elim toggle_friends12_False; blast) moreover then have "IDsOK ?s1' [UID1, UID2] []" by (auto simp: d_defs) moreover have "friendIDs s' = friendIDs ?s1'" using Unfriend(6) f12s1 unfolding s' by (intro eqButUID_deleteFriend12_friendIDs_eq[OF ss1 rs rs1]) ultimately show ?match using ss1 FVal_BO Unfriend UID1_UID2_UIDs vl' vl1' unfolding vl1 fv by (intro matchI[of s1 a1 "outOK" ?s1']) (auto simp: consume_def intro: eqButUID_trans eqButUID_sym intro!: Î3_I[of s' ?s1' vl'' vl1'' vl1' "[]" "[]" vl']) qed auto then show ?thesis .. qed auto next assume nÏ: "Â¬Ï ?trn" then have os': "open s = open s'" and f12s': "friends12 s = friends12 s'" using step_open_Ï[OF step] step_friends12_Ï[OF step] by auto have vl': "vl' = vl" using nÏ c by (auto simp: consume_def) show ?thesis proof (cases "âreq. a â Cact (cFriend UID1 (pass s UID1) UID2) â§ a â Cact (cFriend UID2 (pass s UID2) UID1) â§ a â Cact (cFriendReq UID2 (pass s UID2) UID1 req) â§ a â Cact (cFriendReq UID1 (pass s UID1) UID2 req) â§ a â Dact (dFriend UID1 (pass s UID1) UID2) â§ a â Dact (dFriend UID2 (pass s UID2) UID1)") case True obtain ou1 s1' where step1: "step s1 a = (ou1, s1')" by (cases "step s1 a") auto let ?trn1 = "Trans s1 a ou1 s1'" from True nÏ have nÏ': "Â¬Ï ?trn1" using eqButUID_step_Ï[OF ss1 rs rs1 step step1] by auto then have f12s1': "friends12 s1 = friends12 s1'" and pFRs': "UID1 ââ pendingFReqs s1 UID2 â· UID1 ââ pendingFReqs s1' UID2" "UID2 ââ pendingFReqs s1 UID1 â· UID2 ââ pendingFReqs s1' UID1" using step_friends12_Ï[OF step1] step_pendingFReqs_Ï[OF step1] by auto have "eqButUID s' s1'" using eqButUID_step[OF ss1 step step1 rs rs1] . thm Î3_I[of s' s1' vl'' vl1'' vl1 "[fv]" "[fv]" vl'] then have "Î3 s' vl' s1' vl1" using os vVS1 fs' fs1' FVal_BO unfolding os' f12s1' pFRs' vl' by (intro Î3_I[of s' s1' vl'' vl1'' vl1 "[fv]" "[fv]" vl]) auto then have ?match using step1 nÏ' os eqButUID_step_Î³_out[OF ss1 step step1] by (intro matchI[of s1 a ou1 s1' vl1 vl1]) (auto simp: consume_def) then show "?match â¨ ?ignore" .. next case False with nÏ have "ou â outOK" by auto then have "s' = s" using step False by auto then have ?ignore using 3 False UID1_UID2_UIDs unfolding vl' by (intro ignoreI) auto then show "?match â¨ ?ignore" .. qed qed qed then show ?thesis using fs' by auto next case (OVal vl'' vl1'') then have fs': "filter (Not o isFRVal) vl = OVal True # vl''" and fs1': "filter (Not o isFRVal) vl1 = OVal True # vl1''" and BO'': "BO vl'' vl1''" using fs fs1 by auto from fs fs' have fs: "fs = []" by (cases fs) auto with fs_fIDs have fIDs: "friendIDs s = friendIDs s1" by auto have ?react proof fix a :: act and ou :: out and s' :: state and vl' let ?trn = "Trans s a ou s'" let ?trn1 = "Trans s1 a ou s'" assume step: "step s a = (ou, s')" and T: "Â¬ T ?trn" and c: "consume ?trn vl vl'" show "match ?Î s s1 vl1 a ou s' vl' â¨ ignore ?Î s s1 vl1 a ou s' vl'" (is "?match â¨ ?ignore") proof cases assume Ï: "Ï ?trn" with c have vl: "vl = f ?trn # vl'" by (auto simp: consume_def) with fs' show ?thesis proof (cases "f ?trn") case (FRVal u req) obtain p where a: "(a = Cact (cFriendReq UID1 p UID2 req) â§ UID1 ââ pendingFReqs s' UID2 â§ UID1 â set (pendingFReqs s UID2) â§ (UID2 ââ pendingFReqs s' UID1 â· UID2 ââ pendingFReqs s UID1)) â¨ (a = Cact (cFriendReq UID2 p UID1 req) â§ UID2 ââ pendingFReqs s' UID1 â§ UID2 â set (pendingFReqs s UID1) â§ (UID1 ââ pendingFReqs s' UID2 â· UID1 ââ pendingFReqs s UID2))" "ou = outOK" "Â¬friends12 s" "Â¬friends12 s'" "open s' = open s" using Ï step rs FRVal by (cases rule: ÏE) fastforce+ then have fIDs': "friendIDs s' = friendIDs s" using step by (auto simp: c_defs) have "eqButUID s s'" using a step by (auto intro: Cact_cFriendReq_step_eqButUID) then have "Î3 s' vl' s1 vl1" using ss1 a os OVal(3) vVS1 fs' fs1' fs fs_fs1 fIDs' fIDs unfolding vl FRVal by (intro Î3_I[of s' s1 vl'' vl1'' vl1 fs fs1 vl']) (auto intro: eqButUID_trans eqButUID_sym) moreover from Ï step rs a have "Â¬Î³ (Trans s a ou s')" using UID1_UID2_UIDs by auto ultimately have ?ignore by (intro ignoreI) auto then show ?thesis .. next case (OVal ov') with vl fs' have OVal: "f ?trn = OVal True" and vl': "filter (Not â isFRVal) vl' = vl''" by auto from fs1' nFRVal1 obtain vl1' where vl1: "vl1 = OVal True # vl1'" and vl1': "filter (Not â isFRVal) vl1' = vl1''" by (cases vl1; cases "hd vl1") auto have ?match using Ï step rs OVal proof (cases rule: ÏE) case (OpenF uid p uid') let ?s1' = "createFriend s1 uid p uid'" have s': "s' = createFriend s uid p uid'" using OpenF step by auto from OpenF(2) have uids: "uid â UID1 â§ uid â UID2 â§ uid' = UID1 â¨ uid â UID1 â§ uid â UID2 â§ uid' = UID2 â¨ uid' â UID1 â§ uid' â UID2 â§ uid = UID1 â¨ uid' â UID1 â§ uid' â UID2 â§ uid = UID2" using UID1_UID2_UIDs by auto have "eqButUIDf (pendingFReqs s) (pendingFReqs s1)" using ss1 unfolding eqButUID_def by auto then have "uid' ââ pendingFReqs s uid â· uid' ââ pendingFReqs s1 uid" using OpenF by (intro eqButUIDf_not_UID') auto then have step1: "step s1 a = (outOK, ?s1')" using OpenF step ss1 fIDs unfolding eqButUID_def by (auto simp: c_defs) have s's1': "eqButUID s' ?s1'" using eqButUID_step[OF ss1 step step1 rs rs1] . moreover have os': "open s'" using OpenF unfolding open_def by auto moreover have fIDs': "friendIDs s' = friendIDs ?s1'" using fIDs unfolding s' by (auto simp: c_defs) moreover have f12s1: "friends12 s1 = friends12 ?s1'" "UID1 ââ pendingFReqs s1 UID2 â· UID1 ââ pendingFReqs ?s1' UID2" "UID2 ââ pendingFReqs s1 UID1 â· UID2 ââ pendingFReqs ?s1' UID1" using uids unfolding friends12_def c_defs by auto moreover then have "validValSeqFrom vl1' ?s1'" using vVS1 unfolding vl1 by auto ultimately have "Î1 s' vl' ?s1' vl1'" using BO'' IDsOK_mono[OF step1 IDs1] unfolding Î1_def vl' vl1' by auto moreover have "Ï ?trn â· Ï (Trans s1 a outOK ?s1')" using OpenF(1) uids by (intro eqButUID_step_Ï[OF ss1 rs rs1 step step1]) auto ultimately show ?match using step1 Ï OpenF(1,3,4) unfolding vl1 by (intro matchI[of s1 a outOK ?s1' _ vl1']) (auto simp: consume_def) qed auto then show ?thesis .. qed auto next assume nÏ: "Â¬Ï ?trn" then have os': "open s = open s'" and f12s': "friends12 s = friends12 s'" using step_open_Ï[OF step] step_friends12_Ï[OF step] by auto have vl': "vl' = vl" using nÏ c by (auto simp: consume_def) show ?thesis proof (cases "âreq. a â Cact (cFriend UID1 (pass s UID1) UID2) â§ a â Cact (cFriend UID2 (pass s UID2) UID1) â§ a â Cact (cFriendReq UID2 (pass s UID2) UID1 req) â§ a â Cact (cFriendReq UID1 (pass s UID1) UID2 req) â§ a â Dact (dFriend UID1 (pass s UID1) UID2) â§ a â Dact (dFriend UID2 (pass s UID2) UID1)") case True obtain ou1 s1' where step1: "step s1 a = (ou1, s1')" by (cases "step s1 a") auto let ?trn1 = "Trans s1 a ou1 s1'" from True nÏ have nÏ': "Â¬Ï ?trn1" using eqButUID_step_Ï[OF ss1 rs rs1 step step1] by auto then have f12s1': "friends12 s1 = friends12 s1'" and pFRs': "UID1 ââ pendingFReqs s1 UID2 â· UID1 ââ pendingFReqs s1' UID2" "UID2 ââ pendingFReqs s1 UID1 â· UID2 ââ pendingFReqs s1' UID1" using step_friends12_Ï[OF step1] step_pendingFReqs_Ï[OF step1] by auto have "eqButUID s' s1'" using eqButUID_step[OF ss1 step step1 rs rs1] . moreover have "friendIDs s' = friendIDs s1'" using eqButUID_step_friendIDs_eq[OF ss1 rs rs1 step step1 _ fIDs] True by auto ultimately have "Î3 s' vl' s1' vl1" using os vVS1 fs' fs1' OVal unfolding os' f12s1' pFRs' vl' by (intro Î3_I[of s' s1' vl'' vl1'' vl1 "[]" "[]" vl]) auto then have ?match using step1 nÏ' os eqButUID_step_Î³_out[OF ss1 step step1] by (intro matchI[of s1 a ou1 s1' vl1 vl1]) (auto simp: consume_def) then show "?match â¨ ?ignore" .. next case False with nÏ have "ou â outOK" by auto then have "s' = s" using step False by auto then have ?ignore using 3 False UID1_UID2_UIDs unfolding vl' by (intro ignoreI) auto then show "?match â¨ ?ignore" .. qed qed qed then show ?thesis using fs' by auto next case (FVal1 fv fs' fs1') from this(1) have "False" proof (induction fs' arbitrary: fs) case (Cons fv'' fs'') then obtain fs''' where "map FVal (fv'' # fs''') @ OVal True # vlr = map FVal (fv'' # fs'')" by (cases fs) auto with Cons.IH[of fs'''] show "False" by auto qed auto then show ?thesis .. next case (FVal) then show ?thesis by (induction fs) auto next case (Nil) then show ?thesis by auto qed qed qed definition Gr where "Gr = { (Î0, {Î0,Î1,Î2,Î3}), (Î1, {Î1,Î2,Î3}), (Î2, {Î2,Î1}), (Î3, {Î3,Î1}) }" theorem secure: secure apply (rule unwind_decomp_secure_graph[of Gr Î0]) unfolding Gr_def apply (simp, smt insert_subset order_refl) using istate_Î0 unwind_cont_Î0 unwind_cont_Î1 unwind_cont_Î2 unwind_cont_Î3 unfolding Gr_def by (auto intro: unwind_cont_mono) end

theory Traceback_Intro imports "../Safety_Properties" begin section â¹Traceback Propertiesâº text â¹In this section, we prove traceback properties. These properties trace back the actions leading to: \begin{itemize} \item the current visibility status of a post \item the current friendship status of two users \end{itemize} They state that the current status can only occur via a ``legal'' sequence of actions. Because the BD properties have (dynamic triggers within) declassification bounds that refer to such statuses, the traceback properties complement BD Security in adding confidentiality assurance. \cite[Section 5.2]{cosmed-itp2016} gives more details and explanations. âº end

theory Post_Visibility_Traceback imports Traceback_Intro begin consts PID :: postID consts VIS :: vis subsection â¹Tracing Back Post Visibility Statusâº text â¹We prove the following traceback property: If, at some point â¹tâº on a system trace, the visibility of a post â¹PIDâº has a value â¹VISâº, then one of the following holds: \begin{itemize} \item Either â¹VISâº is â¹FriendVâº (i.e., friends-only) which is the default at post creation \item Or the post's owner had issued a successful ``update visibility'' action setting the visibility to â¹VISâº, and no other successful update actions to â¹PIDâº's visibility occur between the time of that action and â¹tâº. \end{itemize} This will be captured in the predicate â¹properâº, and the main theorem states that â¹proper trâº holds for any trace â¹trâº that leads to post â¹PIDâº acquiring visibility â¹VISâº. âº text â¹â¹SNC uidd trnâº means ``The transaction â¹trnâº is a successful post creation by user â¹uiddâº'' âº fun SNC :: "userID â (state,act,out) trans â bool" where "SNC uidd (Trans s (Cact (cPost uid p pid tit)) ou s') = (ou = outOK â§ (uid,pid) = (uidd,PID))" | "SNC uidd _ = False" text â¹â¹SNVU uidd vvs trnâº means "The transaction â¹trnâº is a successful post visibility update for â¹PIDâº, by user â¹uiddâº, to value â¹vvsâº'' âº fun SNVU :: "userID â vis â (state,act,out) trans â bool" where "SNVU uidd vvs (Trans s (Uact (uVisPost uid p pid vs)) ou s') = (ou = outOK â§ (uid,pid) = (uidd,PID) â§ vs = vvs)" | "SNVU uidd vvis _ = False" definition proper :: "(state,act,out) trans trace â bool" where "proper tr â¡ VIS = FriendV â¨ (â uid tr1 trn tr2 trnn tr3. tr = tr1 @ trn # tr2 @ trnn # tr3 â§ SNC uid trn â§ SNVU uid VIS trnn â§ (â vis. never (SNVU uid vis) tr3))" (* *) definition proper1 :: "(state,act,out) trans trace â bool" where "proper1 tr â¡ â tr2 trnn tr3. tr = tr2 @ trnn # tr3 â§ SNVU (owner (srcOf trnn) PID) VIS trnn" lemma not_never_ex: assumes "Â¬ never P xs" shows "â xs1 x xs2. xs = xs1 @ x # xs2 â§ P x â§ never P xs2" using assms proof(induct xs rule: rev_induct) case (Nil) thus ?case unfolding list_all_iff empty_iff by auto next case (snoc y ys) show ?case proof(cases "P y") case True thus ?thesis using snoc apply(intro exI[of _ ys]) apply(intro exI[of _ y] exI[of _ "[]"]) by auto next case False then obtain xs1 x xs2 where "ys = xs1 @ x # xs2 â§ P x â§ never P xs2" using snoc by auto thus ?thesis using snoc False apply(intro exI[of _ xs1]) apply(intro exI[of _ x] exI[of _ "xs2 ## y"]) by auto qed qed lemma SNVU_postIDs: assumes "validTrans trn" and "SNVU uid vs trn" shows "PID ââ postIDs (srcOf trn)" proof(cases trn) case (Trans s a ou s') then show ?thesis using assms by (cases "a") (auto simp: all_defs elim: step_elims) qed lemma SNVU_visib: assumes "validTrans trn" and "SNVU uid vs trn" shows "vis (tgtOf trn) PID = vs" proof(cases trn) case (Trans s a ou s') then show ?thesis using assms by (cases "a") (auto simp: all_defs elim: step_elims) qed lemma owner_validTrans: assumes "validTrans trn" and "PID ââ postIDs (srcOf trn)" shows "owner (srcOf trn) PID = owner (tgtOf trn) PID" proof(cases trn) case (Trans s a ou s') then show ?thesis using assms by (cases "a") (auto simp: all_defs elim: step_elims) qed lemma owner_valid: assumes "valid tr" and "PID ââ postIDs (srcOf (hd tr))" shows "owner (srcOf (hd tr)) PID = owner (tgtOf (last tr)) PID" using assms using owner_validTrans IDs_mono validTrans by induct auto lemma SNVU_vis_validTrans: assumes "validTrans trn" and "PID ââ postIDs (srcOf trn)" and "â vs. Â¬ SNVU (owner (srcOf trn) PID) vs trn" shows "vis (srcOf trn) PID = vis (tgtOf trn) PID" proof(cases trn) case (Trans s a ou s') then show ?thesis using assms by (cases "a") (auto simp: all_defs elim: step_elims) qed lemma SNVU_vis_valid: assumes "valid tr" and "PID ââ postIDs (srcOf (hd tr))" and "â vis. never (SNVU (owner (srcOf (hd tr)) PID) vis) tr" shows "vis (srcOf (hd tr)) PID = vis (tgtOf (last tr)) PID" using assms proof induct case (Singl) thus ?case using SNVU_vis_validTrans by auto next case (Cons trn tr) have n: "PID ââ postIDs (srcOf (hd tr))" using Cons by (simp add: IDs_mono(2) validTrans) have v: "â vis. never (SNVU (owner (srcOf (hd tr)) PID) vis) tr" using Cons by (simp add: owner_validTrans) have "vis (srcOf trn) PID = vis (srcOf (hd tr)) PID" using Cons SNVU_vis_validTrans by auto also have "... = vis (tgtOf (last tr)) PID" using n v Cons(4) by auto finally show ?case using Cons by auto qed lemma proper1_never: assumes vtr: "valid tr" and PID: "PID ââ postIDs (srcOf (hd tr))" and tr: "proper1 tr" and v: "vis (tgtOf (last tr)) PID = VIS" shows "â tr2 trnn tr3. tr = tr2 @ trnn # tr3 â§ SNVU (owner (srcOf trnn) PID) VIS trnn â§ (â vis. never (SNVU (owner (srcOf trnn) PID) vis) tr3)" proof- obtain tr2 trnn tr3 where tr: "tr = tr2 @ trnn # tr3" and SNVU: "SNVU (owner (srcOf trnn) PID) VIS trnn" using tr unfolding proper1_def by auto define uid where "uid â¡ owner (srcOf trnn) PID" show ?thesis proof(cases "never (Î» trn. â vis. SNVU uid vis trn) tr3") case True thus ?thesis using tr SNVU unfolding uid_def list_all_iff by blast next case False from not_never_ex[OF this] obtain tr3a tr3n tr3b vs where tr3: "tr3 = tr3a @ tr3n # tr3b" and SNVUtr3n: "SNVU uid vs tr3n" and n: "â vs. never (SNVU uid vs) tr3b" unfolding list_all_iff by blast have trnn: "validTrans trnn" and tr3n: "validTrans tr3n" and vtr3: "valid tr3" using tr unfolding tr tr3 by (metis Nil_is_append_conv append_self_conv2 list.distinct(1) tr tr3 valid_ConsE valid_append vtr)+ hence PID_trnn: "PID ââ postIDs (srcOf trnn)" and PID_tr3n: "PID ââ postIDs (srcOf tr3n)" using SNVU_postIDs SNVU SNVUtr3n by auto have vvv: "valid (trnn # tr3a @ [tr3n])" using vtr unfolding tr tr3 by (smt Nil_is_append_conv append_self_conv2 hd_append2 list.distinct(1) list.sel(1) valid_Cons_iff valid_append) hence PID_tr3n': "PID ââ postIDs (tgtOf tr3n)" using tr3n SNVUtr3n by (simp add: IDs_mono(2) PID_tr3n validTrans) from owner_valid[OF vvv] PID_trnn have 000: "owner (tgtOf tr3n) PID = uid" unfolding uid_def by simp hence 0: "owner (srcOf tr3n) PID = uid" using PID_tr3n owner_validTrans tr3n by blast have 00: "vs = vis (tgtOf tr3n) PID" using SNVUtr3n tr3n SNVU_visib by auto have vis: "vs = VIS" proof(cases "tr3b = []") case True thus ?thesis using v 00 unfolding tr tr3 by simp next case False hence tgt: "tgtOf tr3n = srcOf (hd tr3b)" and tr3b: "valid tr3b" using vtr3 unfolding tr3 apply (metis valid_append list.distinct(2) self_append_conv2 valid_ConsE) by (metis False append_self_conv2 list.distinct(1) tr3 valid_Cons_iff valid_append vtr3) show ?thesis unfolding 00 tgt using v False PID_tr3n' using SNVU_vis_valid[OF tr3b _ n[unfolded 000[symmetric] tgt]] unfolding tr tr3 tgt by simp qed show ?thesis apply(intro exI[of _ "tr2 @ trnn # tr3a"]) apply(intro exI[of _ tr3n] exI[of _ tr3b]) using SNVUtr3n n unfolding tr tr3 0 vis by simp qed qed (* *) lemma SNVU_validTrans: assumes "validTrans trn" and "PID ââ postIDs (srcOf trn)" and "vis (srcOf trn) PID â VIS" and "vis (tgtOf trn) PID = VIS" shows "SNVU (owner (srcOf trn) PID) VIS trn" proof(cases trn) case (Trans s a ou s') then show ?thesis using assms by (cases "a") (auto simp: all_defs elim: step_elims) qed lemma valid_mono_postID: assumes "valid tr" and "PID ââ postIDs (srcOf (hd tr))" shows "PID ââ postIDs (tgtOf (last tr))" using assms proof induct case (Singl trn) then show ?case using IDs_mono(2) by (cases trn) auto next case (Cons trn tr) then show ?case using IDs_mono(2) by (cases trn) auto qed lemma proper1_valid: assumes V: "VIS â FriendV" and a: "valid tr" "PID ââ postIDs (srcOf (hd tr))" "vis (srcOf (hd tr)) PID â VIS" "vis (tgtOf (last tr)) PID = VIS" shows "proper1 tr" using a unfolding valid_valid2 proof induct case (Singl trn) then show ?case unfolding proper1_def using SNVU_validTrans by (intro exI[of _ "owner (srcOf trn) PID"] exI[of _ "[]"] exI[of _ trn]) auto next case (Rcons tr trn) hence "PID ââ postIDs (srcOf (hd tr))" using Rcons by simp from valid_mono_postID[OF â¹valid2 trâº[unfolded valid2_valid] this] have "PID ââ postIDs (tgtOf (last tr))" by simp hence 0: "PID ââ postIDs (srcOf trn)" using Rcons by simp show ?case proof(cases "vis (srcOf trn) PID = VIS") case False hence "SNVU (owner (srcOf trn) PID) VIS trn" apply (intro SNVU_validTrans) using 0 Rcons by auto thus ?thesis unfolding proper1_def by (intro exI[of _ tr] exI[of _ trn] exI[of _ "[]"]) auto next case True hence "proper1 tr" using Rcons by auto then obtain trr trnn tr3 where tr: "tr = trr @ trnn # tr3" and SNVU: "SNVU (owner (srcOf trnn) PID) VIS trnn" unfolding proper1_def using V by auto have "vis (tgtOf trn) PID = VIS" using Rcons.prems by auto thus ?thesis using SNVU V unfolding proper1_def tr by(intro exI[of _ trr] exI[of _ trnn] exI[of _ "tr3 ## trn"]) auto qed qed lemma istate_postIDs: "Â¬ PID ââ postIDs istate" unfolding istate_def by simp (* *) definition proper2 :: "(state,act,out) trans trace â bool" where "proper2 tr â¡ â uid tr1 trn tr2. tr = tr1 @ trn # tr2 â§ SNC uid trn" lemma SNC_validTrans: assumes "VIS â FriendV" and "validTrans trn" and "Â¬ PID ââ postIDs (srcOf trn)" and "PID ââ postIDs (tgtOf trn)" shows "â uid. SNC uid trn" proof(cases trn) case (Trans s a ou s') then show ?thesis using assms by (cases "a") (auto simp: all_defs elim: step_elims) qed lemma proper2_valid: assumes V: "VIS â FriendV" and a: "valid tr" "Â¬ PID ââ postIDs (srcOf (hd tr))" "PID ââ postIDs (tgtOf (last tr))" shows "proper2 tr" using a unfolding valid_valid2 proof induct case (Singl trn) then obtain uid where "SNC uid trn" using SNC_validTrans V by auto thus ?case unfolding proper2_def using SNC_validTrans by (intro exI[of _ uid] exI[of _ "[]"] exI[of _ trn]) auto next case (Rcons tr trn) show ?case proof(cases "PID ââ postIDs (srcOf trn)") case False then obtain uid where "SNC uid trn" using Rcons SNC_validTrans V by auto thus ?thesis unfolding proper2_def apply - apply (intro exI[of _ uid] exI[of _ tr]) by (intro exI[of _ trn] exI[of _ "[]"]) auto next case True hence "proper2 tr" using Rcons by auto then obtain uid tr1 trnn tr2 where tr: "tr = tr1 @ trnn # tr2" and SFRC: "SNC uid trnn" unfolding proper2_def by auto have "PID ââ postIDs (tgtOf trn)" using V Rcons.prems by auto show ?thesis using SFRC unfolding proper2_def tr apply - apply (intro exI[of _ uid] exI[of _ tr1]) by (intro exI[of _ trnn] exI[of _ "tr2 ## trn"]) simp qed qed lemma proper2_valid_istate: assumes V: "VIS â FriendV" and a: "valid tr" "srcOf (hd tr) = istate" "PID ââ postIDs (tgtOf (last tr))" shows "proper2 tr" using proper2_valid assms istate_postIDs by auto (* *) lemma SNC_visPost: assumes "VIS â FriendV" and "validTrans trn" "SNC uid trn" and "reach (srcOf trn)" shows "vis (tgtOf trn) PID â VIS" proof(cases trn) case (Trans s a ou s') then show ?thesis using assms apply (cases "a") apply (auto simp: all_defs elim: step_elims) subgoal for x2 apply(cases x2) using reach_not_postIDs_vis_FriendV by (auto simp: all_defs elim: step_elims) . qed lemma SNC_postIDs: assumes "validTrans trn" and "SNC uid trn" shows "PID ââ postIDs (tgtOf trn)" proof(cases trn) case (Trans s a ou s') then show ?thesis using assms by (cases "a") (auto simp: all_defs elim: step_elims) qed lemma SNC_owner: assumes "validTrans trn" and "SNC uid trn" shows "uid = owner (tgtOf trn) PID" proof(cases trn) case (Trans s a ou s') then show ?thesis using assms by (cases "a") (auto simp: all_defs elim: step_elims) qed theorem post_accountability: assumes v: "valid tr" and i: "srcOf (hd tr) = istate" and PIDin: "PID ââ postIDs (tgtOf (last tr))" and PID: "vis (tgtOf (last tr)) PID = VIS" shows "proper tr" proof(cases "VIS = FriendV") case True thus ?thesis unfolding proper_def by auto next case False have "proper2 tr" using proper2_valid_istate[OF False v i PIDin] . then obtain uid tr1 trn trr where tr: "tr = tr1 @ trn # trr" and SNC: "SNC uid trn" unfolding proper2_def by auto hence trn: "validTrans trn" and r: "reach (srcOf trn)" using v unfolding tr apply (metis list.distinct(2) self_append_conv2 valid_ConsE valid_append) by (metis (mono_tags, lifting) append_Cons hd_append i list.sel(1) reach.simps tr v valid_append valid_init_reach) hence N: "PID ââ postIDs (tgtOf trn)" "vis (tgtOf trn) PID â VIS" using SNC_postIDs SNC_visPost False SNC by auto hence trrNE: "trr â []" and 1: "last tr = last trr" using PID unfolding tr by auto hence trr_v: "valid trr" using v unfolding tr by (metis valid_Cons_iff append_self_conv2 list.distinct(1) valid_append) have 0: "tgtOf trn = srcOf (hd trr)" using v trrNE unfolding tr by (metis valid_append list.distinct(2) self_append_conv2 valid_ConsE) have "proper1 trr" using proper1_valid[OF False trr_v N[unfolded 0] PID[unfolded 1]] . from proper1_never[OF trr_v N(1)[unfolded 0] this PID[unfolded 1]] obtain tr2 trnn tr3 where trr: "trr = tr2 @ trnn # tr3" and SNVU: "SNVU (owner (srcOf trnn) PID) VIS trnn" and vis: "â vis. never (SNVU (owner (srcOf trnn) PID) vis) tr3" by auto have 00: "srcOf (hd (tr2 @ [trnn])) = tgtOf trn" using v unfolding tr trr by (metis "0" append_self_conv2 hd_append2 list.sel(1) trr) have trnn: "validTrans trnn" using trr_v unfolding trr by (metis valid_Cons_iff append_self_conv2 list.distinct(1) valid_append) have vv: "valid (tr2 @ [trnn])" using v unfolding tr trr by (smt Nil_is_append_conv append_self_conv2 hd_append2 list.distinct(1) list.sel(1) valid_Cons_iff valid_append) have "uid = owner (tgtOf trn) PID" using SNC trn SNC_owner by auto also have "... = owner (tgtOf trnn) PID" using owner_valid[OF vv] N(1) unfolding 00 by simp also have "... = owner (srcOf trnn) PID" using SNVU trnn SNVU_postIDs owner_validTrans by auto finally have uid: "uid = owner (srcOf trnn) PID" . show ?thesis unfolding proper_def apply(rule disjI2) apply(intro exI[of _ uid] exI[of _ tr1]) apply(rule exI[of _ trn], rule exI[of _ tr2]) apply(intro exI[of _ trnn] exI[of _ tr3]) using SNC SNVU vis unfolding tr trr uid by auto qed end

theory Friend_Traceback imports Traceback_Intro begin subsection â¹Tracing Back Friendship Statusâº text â¹We prove the following traceback property: If, at some point â¹tâº on a system trace, the users â¹UIDâº and â¹UID'âº are friends, then one of the following holds: \begin{itemize} \item Either â¹UIDâº had issued a friend request to â¹UID'âº, eventually followed by an approval (i.e., a successful â¹UIDâº-friend creation action) by â¹UID'âº such that between that approval and â¹tâº there was no successful â¹UID'âº-unfriending (i.e., friend deletion) by â¹UIDâº or â¹UIDâº-unfriending by â¹UID'âº \item Or vice versa (with â¹UIDâº and â¹UID'âº swapped) \end{itemize} This property is captured by the predicate â¹properâº, which decomposes any valid system trace tr starting in the initial state for which the target state â¹tgtOf (last tr)âº has â¹UIDâº and â¹UID'âº as friends, as follows: tr is the concatenation of â¹tr1âº, â¹trnâº, â¹tr2âº, â¹trnnâº and â¹tr3âº where \begin{itemize} \item â¹trnâº represents the time of the relevant friend request \item â¹trnnâº represents the time of the approval of this request \item â¹tr3âº contains no unfriending between the two users \end{itemize} The main theorem states that â¹proper trâº holds for any trace â¹trâº that leads to â¹UIDâº and â¹UID'âº being friends. âº consts UID :: userID consts UID' :: userID text â¹â¹SFRCâº means ``is a successful friend request creation''âº fun SFRC :: "userID â userID â (state,act,out) trans â bool" where "SFRC uidd uidd' (Trans s (Cact (cFriendReq uid p uid' _)) ou s') = (ou = outOK â§ (uid,uid') = (uidd,uidd'))" | "SFRC uidd uidd' _ = False" text â¹â¹SFCâº means ``is a successful friend creation'' âº fun SFC :: "userID â userID â (state,act,out) trans â bool" where "SFC uidd uidd' (Trans s (Cact (cFriend uid p uid')) ou s') = (ou = outOK â§ (uid,uid') = (uidd,uidd'))" | "SFC uidd uidd' _ = False" text â¹â¹SFDâº means ``is a successful friend deletion'' âº fun SFD :: "userID â userID â (state,act,out) trans â bool" where "SFD uidd uidd' (Trans s (Dact (dFriend uid p uid')) ou s') = (ou = outOK â§ (uid,uid') = (uidd,uidd'))" | "SFD uidd uidd' _ = False" definition proper1 :: "(state,act,out) trans trace â bool" where "proper1 tr â¡ â trr trnn tr3. tr = trr @ trnn # tr3 â§ (SFC UID UID' trnn â¨ SFC UID' UID trnn) â§ never (SFD UID UID') tr3 â§ never (SFD UID' UID) tr3" lemma SFC_validTrans: assumes "validTrans trn" and "Â¬ UID' ââ friendIDs (srcOf trn) UID" and "UID' ââ friendIDs (tgtOf trn) UID" shows "SFC UID UID' trn â¨ SFC UID' UID trn" proof(cases trn) case (Trans s a ou s') then show ?thesis using assms by (cases a) (auto elim: step_elims simp: all_defs) qed lemma SFD_validTrans: assumes "validTrans trn" and "UID' ââ friendIDs (tgtOf trn) UID" shows "Â¬ SFD UID UID' trn â§ Â¬ SFD UID' UID trn" proof(cases trn) case (Trans s a ou s') then show ?thesis using assms by (cases a) (auto elim: step_elims simp: all_defs) qed lemma SFC_SFD: assumes "SFC uid1 uid2 trn" shows "Â¬ SFD uid3 uid4 trn" proof(cases trn) case (Trans s a ou s') note trn = Trans show ?thesis using assms unfolding trn by (cases "a") auto qed lemma proper1_valid: assumes "valid tr" and "Â¬ UID' ââ friendIDs (srcOf (hd tr)) UID" and "UID' ââ friendIDs (tgtOf (last tr)) UID" shows "proper1 tr" using assms unfolding valid_valid2 proof induct case (Singl trn) then show ?case unfolding proper1_def using SFC_validTrans by (intro exI[of _ "[]"] exI[of _ trn]) auto next case (Rcons tr trn) show ?case proof(cases "UID' ââ friendIDs (srcOf trn) UID") case False hence "SFC UID UID' trn â¨ SFC UID' UID trn" using Rcons SFC_validTrans by auto thus ?thesis unfolding proper1_def apply - apply (rule exI[of _ tr]) by (intro exI[of _ trn] exI[of _ "[]"]) auto next case True hence "proper1 tr" using Rcons by auto then obtain trr trnn tr3 where tr: "tr = trr @ trnn # tr3" and SFC: "SFC UID UID' trnn â¨ SFC UID' UID trnn" and n: "never (SFD UID UID') tr3 â§ never (SFD UID' UID) tr3" unfolding proper1_def by auto have "UID' ââ friendIDs (tgtOf trn) UID" using Rcons.prems(2) by auto hence SFD: "Â¬ SFD UID UID' trn â§ Â¬ SFD UID' UID trn" using SFD_validTrans â¹validTrans trnâº by auto show ?thesis using SFC n SFD unfolding proper1_def tr apply - apply (rule exI[of _ trr]) by (intro exI[of _ trnn] exI[of _ "tr3 ## trn"]) simp qed qed lemma istate_friendIDs: "Â¬ UID' ââ friendIDs (istate) UID" unfolding istate_def by simp lemma proper1_valid_istate: assumes "valid tr" and "srcOf (hd tr) = istate" and "UID' ââ friendIDs (tgtOf (last tr)) UID" shows "proper1 tr" using assms istate_friendIDs proper1_valid by auto (* *) definition proper2 :: "userID â userID â (state,act,out) trans trace â bool" where "proper2 uid uid' tr â¡ â tr1 trnn tr2. tr = tr1 @ trnn # tr2 â§ SFRC uid uid' trnn" lemma SFRC_validTrans: assumes "validTrans trn" and "Â¬ uid ââ pendingFReqs (srcOf trn) uid'" and "uid ââ pendingFReqs (tgtOf trn) uid'" shows "SFRC uid uid' trn" proof(cases trn) case (Trans s a ou s') then show ?thesis using assms by (cases "a") (auto elim: step_elims simp: all_defs) qed lemma proper2_valid: assumes "valid tr" and "Â¬ uid ââ pendingFReqs (srcOf (hd tr)) uid'" and "uid ââ pendingFReqs (tgtOf (last tr)) uid'" shows "proper2 uid uid' tr" using assms unfolding valid_valid2 proof induct case (Singl trn) thus ?case unfolding proper2_def using SFRC_validTrans by (intro exI[of _ "[]"] exI[of _ trn]) auto next case (Rcons tr trn) show ?case proof(cases "uid ââ pendingFReqs (srcOf trn) uid'") case False hence "SFRC uid uid' trn" using Rcons SFRC_validTrans by auto thus ?thesis unfolding proper2_def apply - apply (rule exI[of _ tr]) by (intro exI[of _ trn] exI[of _ "[]"]) auto next case True hence "proper2 uid uid' tr" using Rcons by auto then obtain trr trnn tr3 where tr: "tr = trr @ trnn # tr3" and SFRC: "SFRC uid uid' trnn" unfolding proper2_def by auto have "uid ââ pendingFReqs (tgtOf trn) uid'" using Rcons.prems(2) by auto show ?thesis using SFRC unfolding proper2_def tr apply - apply (rule exI[of _ trr]) by (intro exI[of _ trnn] exI[of _ "tr3 ## trn"]) simp qed qed lemma istate_pendingFReqs: "Â¬ uid ââ pendingFReqs (istate) uid'" unfolding istate_def by simp lemma proper2_valid_istate: assumes "valid tr" and "srcOf (hd tr) = istate" and "uid ââ pendingFReqs (tgtOf (last tr)) uid'" shows "proper2 uid uid' tr" using assms istate_pendingFReqs proper2_valid by auto (* *) lemma SFC_pendingFReqs: assumes "validTrans trn" and "SFC uid' uid trn" shows "uid ââ pendingFReqs (srcOf trn) uid'" proof(cases trn) case (Trans s a ou s') then show ?thesis using assms by (cases "a") (auto elim: step_elims simp: all_defs) qed definition proper :: "(state,act,out) trans trace â bool" where "proper tr â¡ â tr1 trn tr2 trnn tr3. tr = tr1 @ trn # tr2 @ trnn # tr3 â§ (SFRC UID' UID trn â§ SFC UID UID' trnn â¨ SFRC UID UID' trn â§ SFC UID' UID trnn) â§ never (SFD UID UID') tr3 â§ never (SFD UID' UID) tr3" theorem friend_accountability: assumes v: "valid tr" and i: "srcOf (hd tr) = istate" and UID: "UID' ââ friendIDs (tgtOf (last tr)) UID" shows "proper tr" proof- have "proper1 tr" using proper1_valid_istate[OF assms] . then obtain trr trnn tr3 where tr: "tr = trr @ trnn # tr3" and SFC: "SFC UID UID' trnn â¨ SFC UID' UID trnn" (is "?A â¨ ?B") and n: "never (SFD UID UID') tr3 â§ never (SFD UID' UID) tr3" unfolding proper1_def by auto have trnn: "validTrans trnn" and trr: "valid trr" using tr apply (metis valid_Cons_iff append_self_conv2 assms(1) list.distinct(1) valid_append) by (metis SFC SFC_pendingFReqs append_self_conv2 i istate_pendingFReqs list.distinct(1) list.sel(1) tr v valid_Cons_iff valid_append) show ?thesis using SFC proof assume SFC: ?A have 0: "UID' ââ pendingFReqs (srcOf trnn) UID" using SFC_pendingFReqs[OF trnn SFC] . hence "srcOf trnn â istate" unfolding istate_def by auto hence 2: "trr â []" using i unfolding tr by auto hence i: "srcOf (hd trr) = istate" using i unfolding tr by auto have "srcOf trnn = tgtOf (last trr)" using tr v valid_append 2 by auto hence 1: "UID' ââ pendingFReqs (tgtOf (last trr)) UID" using 0 by simp have "proper2 UID' UID trr" using proper2_valid_istate[OF trr i 1] . then obtain tr1 trn tr2 where trr: "trr = tr1 @ trn # tr2" and SFRC: "SFRC UID' UID trn" unfolding proper2_def by auto show ?thesis unfolding proper_def apply(rule exI[of _ tr1], rule exI[of _ trn], rule exI[of _ tr2], rule exI[of _ trnn], rule exI[of _ tr3]) unfolding tr trr using SFRC SFC n by simp next assume SFC: ?B have 0: "UID ââ pendingFReqs (srcOf trnn) UID'" using SFC_pendingFReqs[OF trnn SFC] . hence "srcOf trnn â istate" unfolding istate_def by auto hence 2: "trr â []" using i unfolding tr by auto hence i: "srcOf (hd trr) = istate" using i unfolding tr by auto have "srcOf trnn = tgtOf (last trr)" using tr v valid_append 2 by auto hence 1: "UID ââ pendingFReqs (tgtOf (last trr)) UID'" using 0 by simp have "proper2 UID UID' trr" using proper2_valid_istate[OF trr i 1] . then obtain tr1 trn tr2 where trr: "trr = tr1 @ trn # tr2" and SFRC: "SFRC UID UID' trn" unfolding proper2_def by auto show ?thesis unfolding proper_def apply(rule exI[of _ tr1], rule exI[of _ trn], rule exI[of _ tr2], rule exI[of _ trnn], rule exI[of _ tr3]) unfolding tr trr using SFRC SFC n by simp qed qed end

Session CoSMed

Theory Prelim

Theory System_Specification

Theory Automation_Setup

Theory Safety_Properties

Theory Observation_Setup

Theory Post_Intro

Theory Post_Value_Setup

Theory Post

Theory Friend_Intro

Theory Friend_Value_Setup

Theory Friend

Theory Friend_Request_Intro

Theory Friend_Request_Value_Setup

Theory Friend_Request

Theory Traceback_Intro

Theory Post_Visibility_Traceback

Theory Friend_Traceback